packages feed

hackport 0.4.7 → 0.5

raw patch · 409 files changed

+37590/−11314 lines, 409 filesdep +base64-bytestringdep +cryptohashdep +ed25519dep ~basesetup-changed

Dependencies added: base64-bytestring, cryptohash, ed25519, ghc-prim, hashable, mtl, split, template-haskell, transformers

Dependency ranges changed: base

Files

.gitmodules view
@@ -1,3 +1,6 @@ [submodule "cabal"] 	path = cabal 	url = git://github.com/gentoo-haskell/cabal.git+[submodule "hackage-security"]+	path = hackage-security+	url = git://github.com/well-typed/hackage-security.git
Cabal2Ebuild.hs view
@@ -51,17 +51,22 @@                                                else Cabal.description pkg,     E.homepage        = thisHomepage,     E.license         = Portage.convertLicense $ Cabal.license pkg,-    E.slot            = (E.slot E.ebuildTemplate) ++ maybe [] (const "/${PV}") (Cabal.library pkg),+    E.slot            = (E.slot E.ebuildTemplate) ++ (if hasLibs then "/${PV}" else ""),     E.my_pn           = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,     E.features        = E.features E.ebuildTemplate-                   ++ (if hasExe then ["bin"] else [])-                   ++ maybe [] (const (["lib","profile","haddock","hoogle"]-                        ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])-                        ) (Cabal.library pkg) -- hscolour can't colour its own sources-                   ++ (if hasTests then ["test-suite"] else [])+                   ++ (if hasExe then ["bin"]+                                 else [])+                   ++ (if hasLibs then (["lib","profile","haddock","hoogle"]+                                        ++ if cabalPkgName == "hscolour"+                                                then []+                                                else ["hscolour"])+                                  else [])+                   ++ (if hasTests then ["test-suite"]+                                   else [])   } where         cabal_pn = Cabal.pkgName $ Cabal.package pkg         cabalPkgName = display cabal_pn+        hasLibs = Cabal.libraries pkg /= []         hasExe = (not . null) (Cabal.executables pkg)         hasTests = (not . null) (Cabal.testSuites pkg)         thisHomepage = if (null $ Cabal.homepage pkg)
− CacheFile.hs 
@@ -1,12 +0,0 @@-module CacheFile where--import System.FilePath--indexFile :: String-indexFile = "00-index.tar.gz"--hackportDir :: String-hackportDir = ".hackport"--cacheFile :: FilePath -> FilePath-cacheFile tree = tree </> hackportDir </> indexFile
− Diff.hs 
@@ -1,188 +0,0 @@-module Diff-    ( runDiff-    , DiffMode(..)-    ) where--import Control.Monad ( mplus )-import Control.Exception ( assert )-import Data.Maybe ( fromJust, listToMaybe )-import Data.List ( sortBy, groupBy )-import Data.Ord ( comparing )--import qualified Portage.Overlay as Portage-import qualified Portage.Cabal as Portage-import qualified Portage.PackageId as Portage--import qualified Data.Version as Cabal---- cabal-import Distribution.Verbosity-import Distribution.Text(display)-import qualified Distribution.Package as Cabal-import qualified Distribution.Client.PackageIndex as Index-import Distribution.Simple.Utils (equating)---- cabal-install-import qualified Distribution.Client.IndexUtils as Index (getSourcePackages)-import qualified Distribution.Client.Types as Cabal-import Distribution.Client.Utils (mergeBy, MergeResult(..))--data DiffMode-	= ShowAll-	| ShowMissing-	| ShowAdditions-	| ShowNewer-	| ShowCommon-        | ShowPackages [String]-	deriving Eq---{--type DiffState a = MergeResult a a-tabs :: String -> String-tabs str = let len = length str in str++(if len < 3*8-	then replicate (3*8-len) ' '-	else "")----- TODO: is the new showPackageCompareInfo showing the packages in the same--- way as showDiffState did?--showDiffState :: Cabal.PackageName -> DiffState Portage.Version -> String-showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of-  InBoth x y -> display x ++ (case compare x y of-    EQ -> "="-    GT -> ">"-    LT -> "<") ++ display y-  OnlyInLeft x -> display x ++ ">none"-  OnlyInRight y -> "none<" ++ display y) ++ "]"--}--runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO ()-runDiff verbosity overlayPath dm repo = do-  -- get package list from hackage-  pkgDB <- Index.getSourcePackages verbosity [ repo ]-  let (Cabal.SourcePackageDb hackageIndex _) = pkgDB--  -- get package list from the overlay-  overlay0 <- (Portage.loadLazy overlayPath)-  let overlayIndex = Portage.fromOverlay (Portage.reduceOverlay overlay0)--  let (subHackage, subOverlay)-        = case dm of-            ShowPackages pkgs ->-              (concatMap (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs-              ,concatMap (concatMap snd . Index.searchByNameSubstring overlayIndex) pkgs)-            _ ->-              (Index.allPackages hackageIndex-              ,Index.allPackages overlayIndex)-  diff subHackage subOverlay dm--data PackageCompareInfo = PackageCompareInfo {-    name :: Cabal.PackageName,---    hackageVersions :: [ Cabal.Version ],---    overlayVersions :: [ Cabal.Version ]-    hackageVersion :: Maybe Cabal.Version,-    overlayVersion :: Maybe Cabal.Version-  } deriving Show--showPackageCompareInfo :: PackageCompareInfo -> String-showPackageCompareInfo pkgCmpInfo =-    display (name pkgCmpInfo) ++ " ["-    ++ hackageS ++ sign ++ overlayS ++ "]" -  where-  overlay = overlayVersion pkgCmpInfo-  hackage = hackageVersion pkgCmpInfo-  hackageS = maybe "none" display hackage-  overlayS = maybe "none" display overlay-  sign = case compare hackage overlay of-          EQ -> "="-          GT -> ">"-          LT -> "<"--diff :: [Cabal.SourcePackage]-     -> [Portage.ExistingEbuild]-     -> DiffMode-     -> IO ()-diff hackage overlay dm = do-  mapM_ (putStrLn . showPackageCompareInfo) pkgCmpInfos-  where-  merged = mergePackages (map (Portage.normalizeCabalPackageId . Cabal.packageId) hackage)-                         (map Portage.ebuildCabalId overlay)-  pkgCmpInfos = filter pkgFilter (map (uncurry mergePackageInfo) merged)-  pkgFilter :: PackageCompareInfo -> Bool-  pkgFilter pkgCmpInfo =-    let om = overlayVersion pkgCmpInfo-        hm = hackageVersion pkgCmpInfo-        st = case (om,hm) of-              (Just ov, Just hv) -> InBoth ov hv-              (Nothing, Just hv) -> OnlyInRight hv-              (Just ov, Nothing) -> OnlyInLeft ov-              _ -> error "impossible"-    in-    case dm of-      ShowAll -> True-      ShowPackages _ -> True -- already filtered-      ShowNewer -> case st of-                     InBoth o h -> h>o-                     _ -> False-      ShowMissing -> case st of-                     OnlyInLeft _ -> False-                     InBoth x y -> x < y-                     OnlyInRight _ -> True-      ShowAdditions -> case st of-                     OnlyInLeft _ -> True-                     InBoth x y -> x > y-                     OnlyInRight _ -> False-      ShowCommon -> case st of-                     OnlyInLeft _ -> False-                     InBoth x y -> x == y-                     OnlyInRight _ -> False- --- | We get the 'PackageCompareInfo' by combining the info for the overlay--- and hackage versions of a package.------ * We're building info about a various versions of a single named package so--- the input package info records are all supposed to refer to the same--- package name.----mergePackageInfo :: [Cabal.PackageIdentifier]-                 -> [Cabal.PackageIdentifier]-                 -> PackageCompareInfo-mergePackageInfo hackage overlay =-  assert (length overlay + length hackage > 0) $-  PackageCompareInfo {-    name              = combine Cabal.pkgName latestHackage-                                Cabal.pkgName latestOverlay,---    hackageVersions = map Cabal.pkgVersion hackage,---    overlayVersions = map Cabal.pkgVersion overlay-    hackageVersion = fmap Cabal.pkgVersion latestHackage,-    overlayVersion = fmap Cabal.pkgVersion latestOverlay-  }-  where-    combine f x g y = fromJust (fmap f x `mplus` fmap g y)-    latestHackage = latestOf hackage-    latestOverlay = latestOf overlay-    latestOf :: [Cabal.PackageIdentifier] -> Maybe Cabal.PackageIdentifier-    latestOf = listToMaybe . reverse . sortBy (comparing Cabal.pkgVersion)---- | Rearrange installed and available packages into groups referring to the--- same package by name. In the result pairs, the lists are guaranteed to not--- both be empty.----mergePackages :: [Cabal.PackageIdentifier] -> [Cabal.PackageIdentifier]-              -> [([Cabal.PackageIdentifier], [Cabal.PackageIdentifier])]-mergePackages hackage overlay =-    map collect-  $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn Cabal.pkgName hackage)-            (groupOn Cabal.pkgName overlay)-  where-    collect (OnlyInLeft  (_,is)       ) = (is, [])-    collect (    InBoth  (_,is) (_,as)) = (is, as)-    collect (OnlyInRight        (_,as)) = ([], as)--groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]-groupOn key = map (\xs -> (key (head xs), xs))-            . groupBy (equating key)-            . sortBy (comparing key)
− DistroMap.hs 
@@ -1,158 +0,0 @@-{-# OPTIONS -XPatternGuards #-}-{--Generate a distromap, like these:-http://hackage.haskell.org/packages/archive/00-distromap/-Format:--("xmobar","0.8",Just "http://packages.gentoo.org/package/x11-misc/xmobar")-("xmobar","0.9",Just "http://packages.gentoo.org/package/x11-misc/xmobar")-("xmobar","0.9.2",Just "http://packages.gentoo.org/package/x11-misc/xmobar")-("xmonad","0.5",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.6",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.7",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.8",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.8.1",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.9",Just "http://packages.gentoo.org/package/x11-wm/xmonad")-("xmonad","0.9.1",Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay")--Multiple entries for each package is allowed, given that there are different versions.---Setup:-  Join all packages from portage and the overlay into a big map;-  From Portage.PackageId: PackageName = category/package-  PVULine = (packagename, versionstring, url)-  Create such a map: Map PackageName DistroLine-  Only one PVULine per version, and prefer portage over the overlay.--Algorithm;-  1. Take a package from hackage-  2. Look for it in the map-    a. For each version:-        find a match in the list of versions:-          yield the PVULine--}--module DistroMap-  ( distroMap ) where--import Control.Applicative-import qualified Data.List as List ( nub )-import qualified Data.Map as Map-import Data.Map ( Map )-import System.FilePath ( (</>) )-import Debug.Trace ( trace )-import Data.Maybe ( fromJust )--import Distribution.Verbosity-import Distribution.Text ( display )-import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )-import Distribution.Simple.Utils ( info )--import qualified Data.Version as Cabal-import qualified Distribution.Package as Cabal-import qualified Distribution.Client.PackageIndex as CabalInstall-import qualified Distribution.Client.IndexUtils as CabalInstall--import Portage.Overlay (  readOverlayByPackage, getDirectoryTree )-import qualified Portage.PackageId as Portage-import qualified Portage.Version as Portage--type PVU = (Cabal.PackageName, Cabal.Version, Maybe String)-type PVU_Map = Map Portage.PackageName [(Cabal.Version, Maybe String)]--distroMap :: Verbosity -> Repo -> FilePath -> FilePath -> [String] -> IO ()-distroMap verbosity repo portagePath overlayPath args = do-  info verbosity "distro map called"-  info verbosity ("verbosity: " ++ show verbosity)-  info verbosity ("portage: " ++ portagePath)-  info verbosity ("overlay: " ++ overlayPath)-  info verbosity ("args: " ++ show args)--  portage <- readOverlayByPackage <$> getDirectoryTree portagePath-  overlay <- readOverlayByPackage <$> getDirectoryTree overlayPath--  info verbosity ("portage packages: " ++ show (length portage))-  info verbosity ("overlay packages: " ++ show (length overlay))--  let portageMap = buildPortageMap portage-      overlayMap = buildOverlayMap overlay-      completeMap = unionMap portageMap overlayMap--  info verbosity ("portage map: " ++ show (Map.size portageMap))-  info verbosity ("overlay map: " ++ show (Map.size overlayMap))-  info verbosity ("complete map: " ++ show (Map.size completeMap))--  SourcePackageDb { packageIndex = packageIndex } <--    CabalInstall.getSourcePackages verbosity [repo]--  let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)-      hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]--  info verbosity ("cabal packages: " ++ show (length hackagePkgs))--  let pvus = concat $ map (\(p,vs) -> lookupPVU completeMap p vs) hackagePkgs-  info verbosity ("found pvus: " ++ show (length pvus))--  mapM_ (putStrLn . showPVU) pvus-  return ()---showPVU :: PVU -> String-showPVU (p,v,u) = show $ (display p, display v, u)---- building the PVU_Map--reduceVersion :: Portage.Version -> Portage.Version-reduceVersion (Portage.Version ns _ _ _) = Portage.Version ns Nothing [] 0--reduceVersions :: [Portage.Version] -> [Portage.Version]-reduceVersions = List.nub . map reduceVersion--buildMap :: [(Portage.PackageName, [Portage.Version])]-         -> (Portage.PackageName -> Portage.Version -> Maybe String)-         -> PVU_Map-buildMap pvs f = Map.mapWithKey (\p vs -> [ (fromJust $ Portage.toCabalVersion v, f p v)-                                          | v <- reduceVersions vs ])-                                (Map.fromList pvs)--buildPortageMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map-buildPortageMap lst = buildMap lst $ \ (Portage.PackageName c p) _v ->-  Just $ "http://packages.gentoo.org/package" </> display c </> display p--buildOverlayMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map-buildOverlayMap lst = buildMap lst $ \_ _ -> Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay"--unionMap :: PVU_Map -> PVU_Map -> PVU_Map-unionMap = Map.unionWith f-  where-  f :: [(Cabal.Version, Maybe String)]-    -> [(Cabal.Version, Maybe String)]-    -> [(Cabal.Version, Maybe String)]-  f vas vbs = Map.toList (Map.union (Map.fromList vas) (Map.fromList vbs))----- resolving Cabal.PackageName to Portage.PackageName--lookupPVU :: PVU_Map -> Cabal.PackageName -> [Cabal.Version] -> [PVU]-lookupPVU pvu_map pn cvs =-  case findItems (Portage.normalizeCabalPackageName pn) of-    [] -> []-    [item] -> ret item-    items | [item] <- preferableItem items -> ret item-          | otherwise -> trace (noDefaultText items) []-  where-  noDefaultText is = unlines $ ("no default for package: " ++ display pn)-                           : [ " * " ++ (display cat)-                             | (Portage.PackageName cat _, _) <- is]--  ret (_, vs) = [ (pn, v, u) | (v, u) <- vs, v `elem` cvs ]-  preferableItem items =-    [ item-    | item@(Portage.PackageName cat _pn, _vs) <- items-    , cat == Portage.Category "dev-haskell"]-  findItems cpn = Map.toList $ Map.filterWithKey f pvu_map-    where-    f (Portage.PackageName _cat _pn) _vs = cpn == pn--
+ HackPort/GlobalFlags.hs view
@@ -0,0 +1,47 @@+module HackPort.GlobalFlags+    ( GlobalFlags(..)+    , defaultGlobalFlags+    , withHackPortContext+    ) where++import qualified Distribution.Verbosity as DV+import qualified Distribution.Simple.Setup as DSS+import qualified Distribution.Client.GlobalFlags as DCG+import qualified Distribution.Client.Types as DCT+import qualified Distribution.Utils.NubList as DUN++import qualified Network.URI as NU++import System.FilePath ((</>))++import qualified Overlays++data GlobalFlags =+    GlobalFlags { globalVersion :: DSS.Flag Bool+                , globalNumericVersion :: DSS.Flag Bool+                , globalPathToOverlay :: DSS.Flag (Maybe FilePath)+                , globalPathToPortage :: DSS.Flag (Maybe FilePath)+                }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags =+    GlobalFlags { globalVersion = DSS.Flag False+                , globalNumericVersion = DSS.Flag False+                , globalPathToOverlay = DSS.Flag Nothing+                , globalPathToPortage = DSS.Flag Nothing+                }++defaultRemoteRepo :: DCT.RemoteRepo+defaultRemoteRepo = (DCT.emptyRemoteRepo name) { DCT.remoteRepoURI = uri }+   where+    Just uri = NU.parseURI "https://hackage.haskell.org/"+    name     = "hackage.haskell.org"++withHackPortContext :: DV.Verbosity -> GlobalFlags -> (DCG.RepoContext -> IO a) -> IO a+withHackPortContext verbosity global_flags callback = do+    overlayPath <- Overlays.getOverlayPath verbosity (DSS.fromFlag $ globalPathToOverlay global_flags)+    let flags = DCG.defaultGlobalFlags {+                    DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo]+                  , DCG.globalCacheDir    = DSS.Flag $ overlayPath </> ".hackport"+                }+    DCG.withRepoContext verbosity flags callback
− Hackage.hs 
@@ -1,35 +0,0 @@-{-|-    Author      :  Sergei Trofimovich <slyfox@gentoo.org>-    Stability   :  experimental-    Portability :  haskell98--    Utilities to work with hackage-alike repositories--}-module Hackage-    ( defaultRepo-    , defaultRepoURI-    ) where--import Distribution.Client.Types (Repo(..), RemoteRepo(..))-import Network.URI (URI(..), URIAuth(..))-import System.FilePath--defaultRepo :: FilePath -> Repo-defaultRepo overlayPath =-  Repo {-      repoKind = Left defaultRemoteRepo,-      repoLocalDir = overlayPath </> ".hackport"-    }---- A copy from cabal-install/Distribution.Client.Config-defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri () False-  where-    name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""--defaultRepoURI :: FilePath -> URI-defaultRepoURI overlayPath =-  case repoKind (defaultRepo overlayPath) of-    Left (RemoteRepo { remoteRepoURI = uri }) -> uri-    Right _                                   -> error $ "defaultRepoURI: unable to get URI for " ++ overlayPath
− Main-GuessGHC.hs 
@@ -1,27 +0,0 @@-module Main where--import System.Environment--import Distribution.PackageDescription-import Distribution.PackageDescription.Parse--import Distribution.Text-import Distribution.Verbosity--import Portage.GHCCore--main :: IO ()-main = do-  args <- getArgs-  gpds <- mapM (readPackageDescription silent) args-  mapM_ guess gpds--guess :: GenericPackageDescription -> IO ()-guess gpd = do-  let pkg = package . packageDescription $ gpd-  let mghc = minimumGHCVersionToBuildPackage gpd-  putStr (display pkg)-  putStr "\t\t"-  putStrLn $ case mghc of-              Nothing -> "Unknown"-              Just (compiler, _pkgs) -> display compiler
Main.hs view
@@ -1,4 +1,4 @@-module Main where+module Main (main) where  import Control.Applicative import Control.Monad@@ -11,10 +11,9 @@ import Distribution.Simple.Setup         ( Flag(..), fromFlag         , trueArg-        , flagToList         , optionVerbosity         )-import Distribution.ReadE ( succeedReadE )+ import Distribution.Simple.Command -- commandsRun import Distribution.Simple.Utils ( die, cabalVersion, warn ) import qualified Distribution.PackageDescription.Parse as Cabal@@ -24,29 +23,24 @@  import Distribution.Client.Types import Distribution.Client.Update-import qualified Distribution.Client.HttpUtils as DCH- import qualified Distribution.Client.PackageIndex as Index import qualified Distribution.Client.IndexUtils as Index -import Hackage (defaultRepo, defaultRepoURI)- import Portage.Overlay as Overlay ( loadLazy, inOverlay ) import Portage.Host as Host ( getInfo, portage_dir ) import Portage.PackageId ( normalizeCabalPackageId ) -import Network.URI ( URI(..), parseURI ) import System.Environment ( getArgs, getProgName ) import System.Directory ( doesDirectoryExist ) import System.Exit ( exitFailure ) import System.FilePath ( (</>) ) -import Diff+import qualified HackPort.GlobalFlags as H+ import Error import Status import Overlays import Merge-import DistroMap ( distroMap )  import qualified Paths_cabal_install import qualified Paths_hackport@@ -57,37 +51,30 @@  data ListFlags = ListFlags {     listVerbosity :: Flag Verbosity-    -- , listOverlayPath :: Flag FilePath-    -- , listServerURI :: Flag String   }  instance Monoid ListFlags where   mempty = ListFlags {     listVerbosity = mempty-    -- , listOverlayPath = mempty-    -- , listServerURI = mempty   }   mappend a b = ListFlags {     listVerbosity = combine listVerbosity-    -- , listOverlayPath = combine listOverlayPath-    -- , listServerURI = combine listServerURI   }     where combine field = field a `mappend` field b  defaultListFlags :: ListFlags defaultListFlags = ListFlags {     listVerbosity = Flag normal-    -- , listOverlayPath = NoFlag-    -- , listServerURI = Flag defaultHackageServerURI   }  listCommand :: CommandUI ListFlags listCommand = CommandUI {     commandName = "list",-    commandSynopsis = "List packages",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for listCommand\n",+    commandSynopsis = "List package versions matching pattern",     commandUsage = usagePackages "list",+    commandDescription = Nothing,+    commandNotes = Nothing,+     commandDefaultFlags = defaultListFlags,     commandOptions = \_showOrParseArgs ->       [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })@@ -100,12 +87,12 @@       ]   } -listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction :: ListFlags -> [String] -> H.GlobalFlags -> IO () listAction flags extraArgs globalFlags = do-  let verbosity = fromFlag (listVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  let repo = defaultRepo overlayPath-  index <- fmap packageIndex (Index.getSourcePackages verbosity [ repo ])+ let verbosity = fromFlag (listVerbosity flags)+ H.withHackPortContext verbosity globalFlags $ \repoContext -> do+  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)+  index <- fmap packageIndex (Index.getSourcePackages verbosity repoContext)   overlay <- Overlay.loadLazy overlayPath   let pkgs | null extraArgs = Index.allPackages index            | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs@@ -146,7 +133,7 @@   , makeEbuildCabalFlags = Flag Nothing   } -makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()+makeEbuildAction :: MakeEbuildFlags -> [String] -> H.GlobalFlags -> IO () makeEbuildAction flags args globalFlags = do   (catstr,cabals) <- case args of                       (category:cabal1:cabaln) -> return (category, cabal1:cabaln)@@ -155,7 +142,7 @@             Just c -> return c             Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr))   let verbosity = fromFlag (makeEbuildVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags)   forM_ cabals $ \cabalFileName -> do     pkg <- Cabal.readPackageDescription normal cabalFileName     mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags)@@ -164,9 +151,10 @@ makeEbuildCommand = CommandUI {     commandName = "make-ebuild",     commandSynopsis = "Make an ebuild from a .cabal file",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for makeEbuildCommand\n",     commandUsage = \_ -> [],+    commandDescription = Nothing,+    commandNotes = Nothing,+     commandDefaultFlags = defaultMakeEbuildFlags,     commandOptions = \_showOrParseArgs ->       [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })@@ -182,106 +170,35 @@   }  -------------------------------------------------------------------------- Diff--------------------------------------------------------------------------data DiffFlags = DiffFlags {-    -- diffMode :: Flag String, -- DiffMode,-    diffVerbosity :: Flag Verbosity-    -- , diffServerURI :: Flag String-  }--instance Monoid DiffFlags where-  mempty = DiffFlags {-    -- diffMode = mempty,-    diffVerbosity = mempty-    -- , diffServerURI = mempty-  }-  mappend a b = DiffFlags {-    -- diffMode = combine diffMode,-    diffVerbosity = combine diffVerbosity-    -- , diffServerURI = combine diffServerURI-  }-    where combine field = field a `mappend` field b--defaultDiffFlags :: DiffFlags-defaultDiffFlags = DiffFlags {-    -- diffMode = Flag "all",-    diffVerbosity = Flag normal-    -- , diffServerURI = Flag defaultHackageServerURI-  }--diffCommand :: CommandUI DiffFlags-diffCommand = CommandUI {-    commandName = "diff",-    commandSynopsis = "Run diff",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for diffCommand\n",-    commandUsage = usagePackages "diff",-    commandDefaultFlags = defaultDiffFlags,-    commandOptions = \_showOrParseArgs ->-      [ optionVerbosity diffVerbosity (\v flags -> flags { diffVerbosity = v })-      {--      , option [] ["mode"]-         "Diff mode, one of: all, newer, missing, additions, common"-         diffMode (\v flags -> flags { diffMode = v })-         (reqArgFlag "MODE") -- I don't know how to map it strictly to DiffMode-      -}-      ]-  }--diffAction :: DiffFlags -> [String] -> GlobalFlags -> IO ()-diffAction flags args globalFlags = do-  let verbosity = fromFlag (diffVerbosity flags)-      -- dm0 = fromFlag (diffMode flags)-  dm <- case args of-          [] -> return ShowAll-          ["all"] -> return ShowAll-          ["missing"] -> return ShowMissing-          ["additions"] -> return ShowAdditions-          ["newer"] -> return ShowNewer-          ["common"] -> return ShowCommon-          ("package":  pkgs) -> return (ShowPackages pkgs)-          -- TODO: ["package",packagePattern] ->-          --          return ShowPackagePattern packagePattern-          _ -> die $ "Unknown mode: " ++ unwords args-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  let repo = defaultRepo overlayPath-  runDiff verbosity overlayPath dm repo------------------------------------------------------------------------- -- Update -----------------------------------------------------------------------  data UpdateFlags = UpdateFlags {     updateVerbosity :: Flag Verbosity-    -- , updateServerURI :: Flag String   }  instance Monoid UpdateFlags where   mempty = UpdateFlags {     updateVerbosity = mempty-    -- , updateServerURI = mempty   }   mappend a b = UpdateFlags {     updateVerbosity = combine updateVerbosity-    -- , updateServerURI = combine updateServerURI   }     where combine field = field a `mappend` field b  defaultUpdateFlags :: UpdateFlags defaultUpdateFlags = UpdateFlags {     updateVerbosity = Flag normal-    -- , updateServerURI = Flag defaultHackageServerURI   }  updateCommand :: CommandUI UpdateFlags updateCommand = CommandUI {     commandName = "update",-    commandSynopsis = "Update the local cache",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for updateCommand\n",+    commandSynopsis = "Update the local package database",     commandUsage = usageFlags "update",+    commandDescription = Nothing,+    commandNotes = Nothing,+     commandDefaultFlags = defaultUpdateFlags,     commandOptions = \_ ->       [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v })@@ -295,16 +212,15 @@       ]   } -updateAction :: UpdateFlags -> [String] -> GlobalFlags -> IO ()+updateAction :: UpdateFlags -> [String] -> H.GlobalFlags -> IO () updateAction flags extraArgs globalFlags = do   unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag (updateVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  http_transport <- DCH.configureTransport verbosity Nothing-  update http_transport verbosity [ defaultRepo overlayPath ]-   +  H.withHackPortContext verbosity globalFlags $ \repoContext ->+    update verbosity repoContext+ ----------------------------------------------------------------------- -- Status -----------------------------------------------------------------------@@ -323,10 +239,11 @@ statusCommand :: CommandUI StatusFlags statusCommand = CommandUI {     commandName = "status",-    commandSynopsis = "Show status(??)",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for statusCommand\n",+    commandSynopsis = "Show up-to-date status against other repos (hackage, ::gentoo)",     commandUsage = usagePackages "status",+    commandDescription = Nothing,+    commandNotes = Nothing,+     commandDefaultFlags = defaultStatusFlags,     commandOptions = \_ ->       [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })@@ -341,14 +258,16 @@       ]   } -statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO ()+statusAction :: StatusFlags -> [String] -> H.GlobalFlags -> IO () statusAction flags args globalFlags = do   let verbosity = fromFlag (statusVerbosity flags)       direction = fromFlag (statusDirection flags)   portagePath <- getPortageDir verbosity globalFlags-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  runStatus verbosity portagePath overlayPath direction args+  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) +  H.withHackPortContext verbosity globalFlags $ \repoContext ->+      runStatus verbosity portagePath overlayPath direction args repoContext+ ----------------------------------------------------------------------- -- Merge -----------------------------------------------------------------------@@ -379,9 +298,10 @@ mergeCommand = CommandUI {     commandName = "merge",     commandSynopsis = "Make an ebuild out of hackage package",-    commandDescription = Just $ \_pname ->-      "TODO: this is the commandDescription for mergeCommand\n",     commandUsage = usagePackages "merge",+    commandDescription = Nothing,+    commandNotes = Nothing,+     commandDefaultFlags = defaultMergeFlags,     commandOptions = \_showOrParseArgs ->       [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })@@ -396,71 +316,18 @@       ]   } -mergeAction :: MergeFlags -> [String] -> GlobalFlags -> IO ()+mergeAction :: MergeFlags -> [String] -> H.GlobalFlags -> IO () mergeAction flags extraArgs globalFlags = do   let verbosity = fromFlag (mergeVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  let repo = defaultRepo overlayPath-  merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath (fromFlag $ mergeCabalFlags flags)---------------------------------------------------------------------------- DistroMap--------------------------------------------------------------------------data DistroMapFlags = DistroMapFlags {-    distroMapVerbosity :: Flag Verbosity-  }--instance Monoid DistroMapFlags where-  mempty = DistroMapFlags {-    distroMapVerbosity = mempty-    -- , mergeServerURI = mempty-  }-  mappend a b = DistroMapFlags {-    distroMapVerbosity = combine distroMapVerbosity-  }-    where combine field = field a `mappend` field b--defaultDistroMapFlags :: DistroMapFlags-defaultDistroMapFlags = DistroMapFlags {-    distroMapVerbosity = Flag normal-  }--distroMapCommand :: CommandUI DistroMapFlags-distroMapCommand = CommandUI {-    commandName = "distromap",-    commandSynopsis = "Build a distromap file",-    commandDescription = Just $ \_pname ->-      "TODO: this is the commandDescription for distroMapCommand\n",-    commandUsage = usagePackages "distromap",-    commandDefaultFlags = defaultDistroMapFlags,-    commandOptions = \_showOrParseArgs ->-      [ optionVerbosity distroMapVerbosity (\v flags -> flags { distroMapVerbosity = v })-      ]-  }+  overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) -distroMapAction :: DistroMapFlags-> [String] -> GlobalFlags -> IO ()-distroMapAction flags extraArgs globalFlags = do-  let verbosity = fromFlag (distroMapVerbosity flags)-  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)-  let repo = defaultRepo overlayPath-  portagePath <- getPortageDir verbosity globalFlags-  distroMap verbosity repo portagePath overlayPath extraArgs+  H.withHackPortContext verbosity globalFlags $ \repoContext ->+    merge verbosity repoContext extraArgs overlayPath (fromFlag $ mergeCabalFlags flags)  ----------------------------------------------------------------------- -- Utils ----------------------------------------------------------------------- -getServerURI :: String -> IO URI-getServerURI str =-  case parseURI str of-    Just uri -> return uri-    Nothing -> throwEx (InvalidServer str)--reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->-              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList- usagePackages :: String -> String -> String usagePackages op_name pname =   "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n"@@ -471,9 +338,9 @@       "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n"       ++ "Flags for " ++ flag_name ++ ":" -getPortageDir :: Verbosity -> GlobalFlags -> IO FilePath+getPortageDir :: Verbosity -> H.GlobalFlags -> IO FilePath getPortageDir verbosity globalFlags = do-  let portagePathM =  fromFlag (globalPathToPortage globalFlags)+  let portagePathM =  fromFlag (H.globalPathToPortage globalFlags)   portagePath <- case portagePathM of                    Nothing -> Host.portage_dir <$> Host.getInfo                    Just path -> return path@@ -486,45 +353,31 @@ -- Main ----------------------------------------------------------------------- -data GlobalFlags =-    GlobalFlags { globalVersion :: Flag Bool-                , globalNumericVersion :: Flag Bool-                , globalPathToOverlay :: Flag (Maybe FilePath)-                , globalPathToPortage :: Flag (Maybe FilePath)-                }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags =-    GlobalFlags { globalVersion = Flag False-                , globalNumericVersion = Flag False-                , globalPathToOverlay = Flag Nothing-                , globalPathToPortage = Flag Nothing-                }--globalCommand :: CommandUI GlobalFlags+globalCommand :: CommandUI H.GlobalFlags globalCommand = CommandUI {     commandName = "",     commandSynopsis = "",-    commandDescription = Just $ \_pname ->-        "TODO: this is the commandDescription for globalCommand\n",+    commandDescription = Nothing,+    commandNotes = Nothing,     commandUsage = \_ -> [],-    commandDefaultFlags = defaultGlobalFlags,++    commandDefaultFlags = H.defaultGlobalFlags,     commandOptions = \_showOrParseArgs ->         [ option ['V'] ["version"]             "Print version information"-            globalVersion (\v flags -> flags { globalVersion = v })+            H.globalVersion (\v flags -> flags { H.globalVersion = v })             trueArg         , option [] ["numeric-version"]             "Print just the version number"-            globalNumericVersion (\v flags -> flags { globalNumericVersion = v })+            H.globalNumericVersion (\v flags -> flags { H.globalNumericVersion = v })             trueArg         , option ['p'] ["overlay-path"]             "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])"-            globalPathToOverlay (\ovrl_path flags -> flags { globalPathToOverlay = ovrl_path })+            H.globalPathToOverlay (\ovrl_path flags -> flags { H.globalPathToOverlay = ovrl_path })             (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))         , option [] ["portage-path"]             "Override path to your portage tree"-            globalPathToPortage (\port_path flags -> flags { globalPathToPortage = port_path })+            H.globalPathToPortage (\port_path flags -> flags { H.globalPathToPortage = port_path })             (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))         ]     }@@ -537,8 +390,8 @@     CommandErrors errs -> printErrors errs     CommandReadyToGo (globalflags, commandParse) -> do       case commandParse of-        _ | fromFlag (globalVersion globalflags)        -> printVersion-          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        _ | fromFlag (H.globalVersion globalflags)        -> printVersion+          | fromFlag (H.globalNumericVersion globalflags) -> printNumericVersion         CommandHelp help        -> printHelp help         CommandList opts        -> printOptionsList opts         CommandErrors errs      -> printErrors errs@@ -563,10 +416,8 @@       [ listCommand `commandAddAction` listAction       , makeEbuildCommand `commandAddAction` makeEbuildAction       , statusCommand `commandAddAction` statusAction-      , diffCommand `commandAddAction` diffAction       , updateCommand `commandAddAction` updateAction       , mergeCommand `commandAddAction` mergeAction-      , distroMapCommand `commandAddAction` distroMapAction       ]  main :: IO ()
Merge.hs view
@@ -31,10 +31,12 @@  -- cabal-install import Distribution.Client.IndexUtils ( getSourcePackages )+import qualified Distribution.Client.GlobalFlags as CabalInstall import qualified Distribution.Client.PackageIndex as Index import Distribution.Client.Types  -- others+import qualified Data.List.Split as DLS import System.Directory ( getCurrentDirectory                         , setCurrentDirectory                         , createDirectoryIfMissing@@ -49,8 +51,6 @@ import qualified Portage.EMeta as EM import Error as E -import Network.URI- import qualified Portage.Cabal as Portage import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage@@ -64,9 +64,6 @@  import qualified Merge.Dependencies as Merge -import qualified Util as U-- (<.>) :: String -> String -> String a <.> b = a ++ '.':b @@ -98,14 +95,14 @@ -- | Given a list of available packages, and maybe a preferred version, -- return the available package with that version. Latest version is chosen -- if no preference.-resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage+resolveVersion :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . packageInfoId)) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails)   where     match avail = ver == Cabal.pkgVersion (packageInfoId avail) -merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> Maybe String -> IO ()-merge verbosity repo _serverURI args overlayPath users_cabal_flags = do+merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO ()+merge verbosity repoContext args overlayPath users_cabal_flags = do   (m_category, user_pName, m_version) <-     case readPackageString args of       Left err -> throwEx err@@ -125,7 +122,7 @@   overlay <- Overlay.loadLazy overlayPath   -- portage_path <- Host.portage_dir `fmap` Host.getInfo   -- portage <- Overlay.loadLazy portage_path-  index <- fmap packageIndex $ getSourcePackages verbosity [ repo ]+  index <- fmap packageIndex $ getSourcePackages verbosity repoContext    -- find all packages that maches the user specified package name   availablePkgs <-@@ -186,7 +183,7 @@                 user_renames = [ (cfn, ein)                                | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb                                ]-                cn_in_mb = map read_fa $ U.split (== ',') user_fas_s+                cn_in_mb = map read_fa $ DLS.splitOn "," user_fas_s                 read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)                 read_fa [] = error $ "read_fas: empty flag?"                 read_fa (op:flag) =@@ -196,7 +193,7 @@                         _     -> (get_rename (op:flag), Nothing)                   where get_rename :: String -> (Cabal.FlagName, String)                         get_rename s =-                            case U.split (== ':') s of+                            case DLS.splitOn ":" s of                                 [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)                                 [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)                                 _                 -> error $ "get_rename: too many components" ++ show (s)@@ -356,14 +353,6 @@       icalate _s [x]    = [x]       icalate  s (x:xs) = (x ++ s) : icalate s xs -      gamesFlags :: [String]-      gamesFlags = ["--prefix=\"${GAMES_PREFIX}\""]--      addGamesFlags :: [String] -> [String]-      addGamesFlags xs-        | Portage.is_games_cat cat = xs ++ gamesFlags-        | otherwise                = xs-       build_configure_call :: [String] -> [String]       build_configure_call [] = []       build_configure_call conf_args = icalate " \\" $@@ -386,7 +375,8 @@                . (\e -> e { E.depend_extra  = S.toList $ Merge.dep_e tdeps } )                . (\e -> e { E.rdepend       =            Merge.rdep tdeps} )                . (\e -> e { E.rdepend_extra = S.toList $ Merge.rdep_e tdeps } )-               . (\e -> e { E.src_configure = build_configure_call $ addGamesFlags $ selected_flags (active_flags, user_specified_fas) } )+               . (\e -> e { E.src_configure = build_configure_call $+                                                  selected_flags (active_flags, user_specified_fas) } )                . (\e -> e { E.iuse = E.iuse e ++ map to_iuse active_flag_descs })                . ( case requested_cabal_flags of                        Nothing  -> id
Merge/Dependencies.hs view
@@ -114,7 +114,7 @@   where     -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p     treatAsLibrary :: Bool-    treatAsLibrary = isJust (Cabal.library pkg)+    treatAsLibrary = Cabal.libraries pkg /= []     -- without slot business     raw_haskell_deps :: Portage.Dependency     raw_haskell_deps = PN.normalize_depend $ Portage.DependAllOf $ haskellDependencies overlay (buildDepends pkg)@@ -230,14 +230,14 @@ ---------------------------------------------------------------  findCLibs :: PackageDescription -> [Portage.Dependency]-findCLibs (PackageDescription { library = lib, executables = exes }) =+findCLibs (PackageDescription { libraries = libs, executables = exes }) =   [ trace ("WARNING: This package depends on a C library we don't know the portage name for: " ++ p ++ ". Check the generated ebuild.")           (any_c_p "unknown-c-lib" p)   | p <- notFound   ] ++   found   where-  libE = maybe [] (extraLibs.libBuildInfo) lib+  libE = concatMap (extraLibs . libBuildInfo) libs   exeE = concatMap extraLibs (filter buildable (map buildInfo exes))   allE = libE ++ exeE @@ -357,6 +357,7 @@       , ("SDL_gfx", any_c_p "media-libs" "sdl-gfx")       , ("SDL_image", any_c_p "media-libs" "sdl-image")       , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf")+      , ("odbc", any_c_p "dev-db" "unixODBC")       ]  ---------------------------------------------------------------@@ -364,7 +365,7 @@ ---------------------------------------------------------------  buildToolsDependencies :: PackageDescription -> [Portage.Dependency]-buildToolsDependencies (PackageDescription { library = lib, executables = exes }) = nub $+buildToolsDependencies (PackageDescription { libraries = libs, executables = exes }) = nub $   [ case pkg of       Just p -> p       Nothing -> trace ("WARNING: Unknown build tool '" ++ pn ++ "'. Check the generated ebuild.")@@ -374,7 +375,7 @@   ]   where   cabalDeps = filter notProvided $ depL ++ depE-  depL = maybe [] (buildTools.libBuildInfo) lib+  depL = concatMap (buildTools . libBuildInfo) libs   depE = concatMap buildTools (filter buildable (map buildInfo exes))   notProvided (Cabal.Dependency (Cabal.PackageName pn) _range) = pn `notElem` buildToolsProvided @@ -405,10 +406,10 @@ ---------------------------------------------------------------  pkgConfigDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]-pkgConfigDependencies overlay (PackageDescription { library = lib, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps+pkgConfigDependencies overlay (PackageDescription { libraries = libs, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps   where   cabalDeps = depL ++ depE-  depL = maybe [] (pkgconfigDepends.libBuildInfo) lib+  depL = concatMap (pkgconfigDepends . libBuildInfo) libs   depE = concatMap pkgconfigDepends (filter buildable (map buildInfo exes))  resolvePkgConfigs :: Portage.Overlay -> [Cabal.Dependency] -> [Portage.Dependency]@@ -517,4 +518,11 @@   ,("libpq",                       ("dev-db", "postgresql", Portage.AnySlot))   ,("poppler-glib",                ("app-text", "poppler", Portage.AnySlot))   ,("gsl",                         ("sci-libs", "gsl", Portage.AnySlot))+  ,("libvirt",                     ("app-emulation", "libvirt", Portage.AnySlot))++  ,("Qt5Core",                     ("dev-qt", "qtcore", Portage.GivenSlot "5"))+  ,("Qt5Gui",                      ("dev-qt", "qtgui", Portage.GivenSlot "5"))+  ,("Qt5Qml",                      ("dev-qt", "qtdeclarative", Portage.GivenSlot "5"))+  ,("Qt5Quick",                    ("dev-qt", "qtdeclarative", Portage.GivenSlot "5"))+  ,("Qt5Widgets",                  ("dev-qt", "qtwidgets", Portage.GivenSlot "5"))   ]
Overlays.hs view
@@ -5,11 +5,10 @@ import Control.Monad import Data.List (nub, inits) import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust)-import System.Directory+import qualified System.Directory as SD import System.FilePath ((</>), splitPath, joinPath)  import Error-import CacheFile import Portage.Host  -- cabal@@ -32,7 +31,7 @@     let loop [] = throwEx (MultipleOverlays mul)         loop (x:xs) = do           info verbosity $ "Checking '" ++ x ++ "'..."-          found <- doesFileExist (cacheFile x)+          found <- SD.doesDirectoryExist (x </> ".hackport")           if found             then do               info verbosity "OK!"@@ -62,10 +61,9 @@  getLocalOverlay :: IO (Maybe FilePath) getLocalOverlay = do-  curDir <- getCurrentDirectory+  curDir <- SD.getCurrentDirectory   let lookIn = map joinPath . reverse . inits . splitPath $ curDir   fmap listToMaybe (filterM probe lookIn)    where-    probe dir = doesDirectoryExist (dir </> "dev-haskell")-+    probe dir = SD.doesDirectoryExist (dir </> "dev-haskell")
Portage/EBuild.hs view
@@ -7,7 +7,6 @@         ) where  import Portage.Dependency-import qualified Portage.PackageId as PI import qualified Portage.Dependency.Normalize as PN  import Data.String.Utils@@ -18,9 +17,7 @@ import Data.Version(Version(..)) import qualified Paths_hackport(version) -#if MIN_VERSION_time(1,5,0)-import qualified System.Locale as SL-#else+#if ! MIN_VERSION_time(1,5,0) import qualified System.Locale as TC #endif @@ -96,13 +93,13 @@   ss "# Distributed under the terms of the GNU General Public License v2". nl.   ss "# $Id$". nl.   nl.-  ss "EAPI=5". nl.+  ss "EAPI=6". nl.   nl.   ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.   sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild).   nl.   ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.-  ss "inherit haskell-cabal". if_games (ss " games") . nl.+  ss "inherit haskell-cabal". nl.   nl.   (case my_pn ebuild of      Nothing -> id@@ -125,11 +122,6 @@      Nothing -> id      Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl). -  if_games (nl . ss "pkg_setup() {" . nl.-            ss (tabify_line " games_pkg_setup") . nl.-            ss (tabify_line " haskell-cabal_pkg_setup") . nl.-            ss "}" . nl).-   verbatim (nl . ss "src_prepare() {" . nl)                (src_prepare ebuild)            (ss "}" . nl).@@ -138,20 +130,6 @@                (src_configure ebuild)            (ss "}" . nl). -  if_games (nl . ss "src_compile() {" . nl.-            ss (tabify_line " haskell-cabal_src_compile") . nl.-            ss "}" . nl).--  if_games (nl . ss "src_install() {" . nl.-            ss (tabify_line " haskell-cabal_src_install") . nl.-            ss (tabify_line " prepgamesdirs") . nl.-            ss "}" . nl).--  if_games (nl . ss "pkg_postinst() {" . nl.-            ss (tabify_line " haskell-cabal_pkg_postinst") . nl.-            ss (tabify_line " games_pkg_postinst") . nl.-            ss "}" . nl).-   id $ []   where         expandVars = replaceMultiVars [ (        name ebuild, "${PN}")@@ -162,10 +140,6 @@         toHttps  = replace "http://github.com/" "https://github.com/"         this_year :: String         this_year = TC.formatTime TC.defaultTimeLocale "%Y" now-        if_games :: DString -> DString-        if_games ds = if PI.is_games_cat (PI.Category (category ebuild))-                          then ds-                          else id  -- "+a" -> "a" -- "b"  -> "b"
Portage/GHCCore.hs view
@@ -95,8 +95,7 @@ mkIndex :: [PackageIdentifier] -> InstalledPackageIndex mkIndex pids = fromList   [ emptyInstalledPackageInfo-      { IPI.installedPackageId = InstalledPackageId $ display name ++ "-" ++  display version-      , sourcePackageId = pindex+      { sourcePackageId = pindex       , exposed = True       }   | pindex@(PackageIdentifier name version) <- pids ]
Portage/Host.hs view
@@ -4,6 +4,7 @@   ) where  import Util (run_cmd)+import qualified Data.List.Split as DLS import Data.Maybe (fromJust, isJust, catMaybes) import Control.Applicative ( (<$>) ) @@ -73,7 +74,7 @@  parsePaludisInfo :: String -> LocalInfo parsePaludisInfo text =-  let chunks = splitBy (=="") . lines $ text+  let chunks = DLS.splitOn [""] . lines $ text       repositories = catMaybes (map parseRepository chunks)   in  fromJust (mkLocalInfo repositories)   where@@ -97,13 +98,6 @@               , portage_dir = gentooLocation               , overlay_list = overlays               })--splitBy :: (a -> Bool) -> [a] -> [[a]]-splitBy _ [] = []-splitBy c lst =-  let (x,xs) = break c lst-      (_,xs') = span c xs-  in x : splitBy c xs'  --------- -- Emerge
Portage/PackageId.hs view
@@ -12,12 +12,10 @@     normalizeCabalPackageName,     normalizeCabalPackageId,     packageIdToFilePath,-    cabal_pn_to_PN,-    is_games_cat+    cabal_pn_to_PN   ) where  import Data.Char-import qualified Data.List as L  import qualified Distribution.Package as Cabal import Distribution.Text (Text(..))@@ -131,6 +129,3 @@  cabal_pn_to_PN :: Cabal.PackageName -> String cabal_pn_to_PN = map toLower . display--is_games_cat :: Category -> Bool-is_games_cat = L.isPrefixOf "games" . unCategory
− Progress.hs 
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Progress--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Progress (-    Progress(..),-    fold, unfold, fromList,-  ) where--import Prelude hiding (fail)---- | A type to represent the unfolding of an expensive long running--- calculation that may fail. We may get intermediate steps before the final--- retult which may be used to indicate progress and\/or logging messages.----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done---- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with--- two base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----fold :: (step -> a -> a) -> (fail -> a) -> (done -> a)-     -> Progress step fail done -> a-fold step fail done = go-  where-    go (Step s p) = step s (go p)-    go (Fail f)   = fail f-    go (Done r)   = done r--unfold :: (s -> Either (Either fail done) (step, s))-       -> s -> Progress step fail done-unfold f = go-  where-    go s = case f s of-      Left (Left  fail) -> Fail fail-      Left (Right done) -> Done done-      Right (step, s')  -> Step step (go s')--fromList :: [a] -> Progress () b [a]-fromList xs0 = unfold next xs0-  where-    next []     = Left (Right xs0)-    next (_:xs) = Right ((), xs)--instance Functor (Progress step fail) where-  fmap f = fold Step Fail (Done . f)--instance Monad (Progress step fail) where-  return a = Done a-  p >>= f  = fold Step Fail f p
README.rst view
@@ -23,6 +23,7 @@     $ cd ~/overlays     $ git clone git://github.com/gentoo-haskell/gentoo-haskell.git     $ cd gentoo-haskell+    $ mkdir .hackport     $ hackport update     $ ls -1 .hackport/         00-index.tar
Setup.hs view
@@ -1,5 +1,5 @@ #!/usr/bin/runhaskell-module Main where+module Main (main) where  import Distribution.Simple
Status.hs view
@@ -28,16 +28,15 @@ import Control.Monad  -- cabal-import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )+import Distribution.Client.Types ( SourcePackageDb(..), SourcePackage(..) ) import Distribution.Verbosity import Distribution.Package (pkgName) import Distribution.Simple.Utils (comparing, die, equating) import Distribution.Text ( display, simpleParse ) -import qualified Distribution.Client.PackageIndex as CabalInstall+import qualified Distribution.Client.GlobalFlags as CabalInstall import qualified Distribution.Client.IndexUtils as CabalInstall--import Hackage (defaultRepo)+import qualified Distribution.Client.PackageIndex as CabalInstall  data StatusDirection     = PortagePlusOverlay@@ -76,9 +75,9 @@   -loadHackage :: Verbosity -> Distribution.Client.Types.Repo -> Overlay -> IO [[PackageId]]-loadHackage verbosity repo overlay = do-    SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity [repo]+loadHackage :: Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]]+loadHackage verbosity repoContext overlay = do+    SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext     let get_cat cabal_pkg = case resolveCategories overlay (pkgName cabal_pkg) of                                 []    -> Category "dev-haskell"                                 [cat] -> cat@@ -89,11 +88,10 @@                         (CabalInstall.allPackagesByName pindex)     return pkg_infos -status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild])-status verbosity portdir overlaydir = do-    let repo = defaultRepo overlaydir+status :: Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild])+status verbosity portdir overlaydir repoContext = do     overlay <- loadLazy overlaydir-    hackage <- loadHackage verbosity repo overlay+    hackage <- loadHackage verbosity repoContext overlay     portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir     let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) @@ -132,8 +130,8 @@   ebuilds <- Map.lookup (packageId pkgid) overlay   List.find (\e -> ebuildId e == pkgid) ebuilds -runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> IO ()-runStatus verbosity portdir overlaydir direction pkgs = do+runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO ()+runStatus verbosity portdir overlaydir direction pkgs repoContext = do   let pkgFilter = case direction of                       OverlayToPortage   -> toPortageFilter                       PortagePlusOverlay -> id@@ -142,7 +140,7 @@             case simpleParse p of               Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")               Just pn -> return pn-  tree0 <- status verbosity portdir overlaydir+  tree0 <- status verbosity portdir overlaydir repoContext   let tree = pkgFilter tree0   if (null pkgs')     then statusPrinter tree
Util.hs view
@@ -8,7 +8,6 @@  module Util     ( run_cmd -- :: String -> IO (Maybe String)-    , split -- :: (a -> Bool) -> [a] -> [[a]]     ) where  import System.IO@@ -30,10 +29,3 @@                  return $ if (output == "" || exitCode /= ExitSuccess)                           then Nothing                           else Just output--split :: Eq a => (a -> Bool) -> [a] -> [[a]]-split _ [] = []-split p xs =-    case break p xs of-        (l, [])  -> [l]-        (l, _:r) -> l: split p r
+ cabal/.arcconfig view
@@ -0,0 +1,4 @@+{+  "repository.callsign" : "CABAL",+  "phabricator.uri"     : "https://phabricator.haskell.org"+}
cabal/.gitignore view
@@ -15,9 +15,11 @@ /Cabal/dist/ /Cabal/tests/Setup /Cabal/Setup+/Cabal/source-file-list  /cabal-install/dist/ /cabal-install/Setup+/cabal-install/source-file-list   # editor temp files@@ -26,6 +28,7 @@ .#* *~ .*.swp+*.bak  # GHC build @@ -41,3 +44,11 @@  # stack artifacts /.stack-work/++# Shake artifacts+.shake*+progress.txt++# test files+dist-test+register.sh
cabal/.travis.yml view
@@ -1,70 +1,37 @@ # NB: don't set `language: haskell` here -# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.+# The following enables several GHC versions to be tested; often it's enough to+# test only against the last release in a major GHC version. Feel free to omit+# lines listings versions you don't need/want testing for. env:  - GHCVER=7.4.2  - GHCVER=7.6.3  - GHCVER=7.8.4- - GHCVER=7.10.1+ - GHCVER=7.10.3+ - GHCVER=8.0.1 TEST_OLDER=YES+ # TODO add PARSEC_BUNDLED=YES when it's so  - GHCVER=head  # Note: the distinction between `before_install` and `install` is not important. before_install:  - travis_retry sudo add-apt-repository -y ppa:hvr/ghc  - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-1.22 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH+ - travis_retry sudo apt-get install cabal-install-1.24 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy+ - if [ "$TEST_OLDER" == "YES" ]; then travis_retry sudo apt-get install ghc-7.0.4-prof ghc-7.0.4-dyn ghc-7.2.2-prof ghc-7.2.2-dyn; fi+ - export PATH=$HOME/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/1.24/bin:$PATH+ - git version  install:  - cabal update-# We intentionally do not install anything before trying to build Cabal because-# it should build with each supported GHC version out-of-the-box.+ # We intentionally do not install anything before trying to build Cabal because+ # it should build with each supported GHC version out-of-the-box. -# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.-# Using ./dist/setup/setup here instead of cabal-install to avoid breakage-# when the build config format changed+# Here starts the actual work to be performed for the package under test; any+# command which exits with a non-zero exit code causes the build to fail. Using+# ./dist/setup/setup here instead of cabal-install to avoid breakage when the+# build config format changed. script:- - cd Cabal- - mkdir -p ./dist/setup- - cp Setup.hs ./dist/setup/setup.hs-# Should be able to build setup without extra dependencies- - /opt/ghc/$GHCVER/bin/ghc --make -odir ./dist/setup -hidir ./dist/setup -i -i. ./dist/setup/setup.hs -o ./dist/setup/setup -Wall -Werror -threaded  # the command cabal-install would use to build setup--# Need extra dependencies for test suite- - cabal install --only-dependencies --enable-tests- - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache- - /opt/ghc/$GHCVER/bin/ghc-pkg recache --user-- - ./dist/setup/setup configure --user --enable-tests --enable-benchmarks --ghc-option=-Werror -v2  # -v2 provides useful information for debugging- - ./dist/setup/setup build   # this builds all libraries and executables (including tests/benchmarks)- - ./dist/setup/setup haddock # see #2198- - ./dist/setup/setup test --show-details=streaming- - cabal check- - cabal sdist   # tests that a source-distribution can be generated--# The following scriptlet checks that the resulting source distribution can be built & installed- - function install_from_tarball {-   export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;-   if [ -f "dist/$SRC_TGZ" ]; then-      cabal install "dist/$SRC_TGZ" -v2;-   else-      echo "expected 'dist/$SRC_TGZ' not found";-      exit 1;-   fi-   }- - install_from_tarball--# Also build cabal-install.- - cd ../cabal-install- - cabal sandbox init- - cabal sandbox add-source ../Cabal- - cabal install --dependencies-only --enable-tests- - cabal configure --enable-tests --ghc-option=-Werror- - cabal build- - cabal test- - cabal check- - cabal sdist- - install_from_tarball+ - ./travis-script.sh  matrix:   allow_failures:
cabal/Cabal/Cabal.cabal view
@@ -1,5 +1,5 @@ name: Cabal-version: 1.23.0.0+version: 1.25.0.0 copyright: 2003-2006, Isaac Jones            2005-2011, Duncan Coutts license: BSD3@@ -19,9 +19,9 @@   organizing, and cataloging Haskell libraries and tools. category: Distribution cabal-version: >=1.10-build-type: Custom--- Even though we do use the default Setup.lhs it's vital to bootstrapping--- that we build Setup.lhs using our own local Cabal source code.+build-type: Simple+-- If we use a new Cabal feature, this needs to be changed to Custom so+-- we can bootstrap.  extra-source-files:   README.md tests/README.md changelog@@ -29,7 +29,13 @@   doc/installing-packages.markdown   doc/misc.markdown -  -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':+  -- Generated with 'misc/gen-extra-source-files.sh'+  -- Do NOT edit this section manually; instead, run the script.+  -- BEGIN gen-extra-source-files+  tests/PackageTests/AllowNewer/AllowNewer.cabal+  tests/PackageTests/AllowNewer/benchmarks/Bench.hs+  tests/PackageTests/AllowNewer/src/Foo.hs+  tests/PackageTests/AllowNewer/tests/Test.hs   tests/PackageTests/BenchmarkExeV10/Foo.hs   tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs   tests/PackageTests/BenchmarkExeV10/my.cabal@@ -74,18 +80,78 @@   tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs   tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs   tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal+  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs+  tests/PackageTests/BuildableField/BuildableField.cabal+  tests/PackageTests/BuildableField/Main.hs   tests/PackageTests/CMain/Bar.hs-  tests/PackageTests/CMain/Setup.hs   tests/PackageTests/CMain/foo.c   tests/PackageTests/CMain/my.cabal+  tests/PackageTests/Configure/A.hs+  tests/PackageTests/Configure/Setup.hs+  tests/PackageTests/Configure/X11.cabal+  tests/PackageTests/CopyComponent/Exe/Main.hs+  tests/PackageTests/CopyComponent/Exe/Main2.hs+  tests/PackageTests/CopyComponent/Exe/myprog.cabal+  tests/PackageTests/CopyComponent/Lib/Main.hs+  tests/PackageTests/CopyComponent/Lib/p.cabal+  tests/PackageTests/CopyComponent/Lib/src/P.hs+  tests/PackageTests/CustomPreProcess/Hello.hs+  tests/PackageTests/CustomPreProcess/MyCustomPreprocessor.hs+  tests/PackageTests/CustomPreProcess/Setup.hs+  tests/PackageTests/CustomPreProcess/internal-preprocessor-test.cabal   tests/PackageTests/DeterministicAr/Lib.hs   tests/PackageTests/DeterministicAr/my.cabal+  tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal+  tests/PackageTests/DuplicateModuleName/src/Foo.hs+  tests/PackageTests/DuplicateModuleName/tests/Foo.hs+  tests/PackageTests/DuplicateModuleName/tests2/Foo.hs   tests/PackageTests/EmptyLib/empty/empty.cabal+  tests/PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/SameDirectory/ghc+  tests/PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg+  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10+  tests/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10+  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10+  tests/PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10+  tests/PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc+  tests/PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg+  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10+  tests/PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10+  tests/PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal+  tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10+  tests/PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10   tests/PackageTests/Haddock/CPP.hs   tests/PackageTests/Haddock/Literate.lhs   tests/PackageTests/Haddock/NoCPP.hs   tests/PackageTests/Haddock/Simple.hs   tests/PackageTests/Haddock/my.cabal+  tests/PackageTests/HaddockNewline/A.hs+  tests/PackageTests/HaddockNewline/HaddockNewline.cabal+  tests/PackageTests/HaddockNewline/Setup.hs+  tests/PackageTests/InternalLibraries/Executable/exe/Main.hs+  tests/PackageTests/InternalLibraries/Executable/foo.cabal+  tests/PackageTests/InternalLibraries/Executable/src/Foo.hs+  tests/PackageTests/InternalLibraries/Library/fooexe/Main.hs+  tests/PackageTests/InternalLibraries/Library/fooexe/fooexe.cabal+  tests/PackageTests/InternalLibraries/Library/foolib/Foo.hs+  tests/PackageTests/InternalLibraries/Library/foolib/foolib.cabal+  tests/PackageTests/InternalLibraries/Library/foolib/private/Internal.hs+  tests/PackageTests/InternalLibraries/p/Foo.hs+  tests/PackageTests/InternalLibraries/p/p.cabal+  tests/PackageTests/InternalLibraries/p/p/P.hs+  tests/PackageTests/InternalLibraries/p/q/Q.hs+  tests/PackageTests/InternalLibraries/q/Q.hs+  tests/PackageTests/InternalLibraries/q/q.cabal+  tests/PackageTests/Macros/A.hs+  tests/PackageTests/Macros/B.hs+  tests/PackageTests/Macros/Main.hs+  tests/PackageTests/Macros/macros.cabal+  tests/PackageTests/Macros/src/C.hs+  tests/PackageTests/Options.hs   tests/PackageTests/OrderFlags/Foo.hs   tests/PackageTests/OrderFlags/my.cabal   tests/PackageTests/PathsModule/Executable/Main.hs@@ -94,6 +160,9 @@   tests/PackageTests/PreProcess/Foo.hsc   tests/PackageTests/PreProcess/Main.hs   tests/PackageTests/PreProcess/my.cabal+  tests/PackageTests/PreProcessExtraSources/Foo.hsc+  tests/PackageTests/PreProcessExtraSources/Main.hs+  tests/PackageTests/PreProcessExtraSources/my.cabal   tests/PackageTests/ReexportedModules/ReexportedModules.cabal   tests/PackageTests/TemplateHaskell/dynamic/Exe.hs   tests/PackageTests/TemplateHaskell/dynamic/Lib.hs@@ -107,20 +176,33 @@   tests/PackageTests/TemplateHaskell/vanilla/Lib.hs   tests/PackageTests/TemplateHaskell/vanilla/TH.hs   tests/PackageTests/TemplateHaskell/vanilla/my.cabal+  tests/PackageTests/TestNameCollision/child/Child.hs+  tests/PackageTests/TestNameCollision/child/child.cabal+  tests/PackageTests/TestNameCollision/child/tests/Test.hs+  tests/PackageTests/TestNameCollision/parent/Parent.hs+  tests/PackageTests/TestNameCollision/parent/parent.cabal   tests/PackageTests/TestOptions/TestOptions.cabal   tests/PackageTests/TestOptions/test-TestOptions.hs   tests/PackageTests/TestStanza/my.cabal   tests/PackageTests/TestSuiteTests/ExeV10/Foo.hs   tests/PackageTests/TestSuiteTests/ExeV10/my.cabal   tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs-  tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal+  tests/PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs   tests/PackageTests/TestSuiteTests/LibV09/Lib.hs+  tests/PackageTests/TestSuiteTests/LibV09/LibV09.cabal   tests/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs+  tests/PackageTests/Tests.hs+  tests/PackageTests/UniqueIPID/P1/M.hs+  tests/PackageTests/UniqueIPID/P1/my.cabal+  tests/PackageTests/UniqueIPID/P2/M.hs+  tests/PackageTests/UniqueIPID/P2/my.cabal+  tests/PackageTests/multInst/my.cabal   tests/Setup.hs   tests/hackage/check.sh   tests/hackage/download.sh   tests/hackage/unpack.sh   tests/misc/ghc-supported-languages.hs+  -- END gen-extra-source-files  source-repository head   type:     git@@ -132,21 +214,21 @@  library   build-depends:-    base       >= 4.4 && < 5,-    deepseq    >= 1.3 && < 1.5,-    filepath   >= 1   && < 1.5,-    directory  >= 1   && < 1.3,-    process    >= 1.1.0.1 && < 1.4,-    time       >= 1.1 && < 1.6,-    containers >= 0.1 && < 0.6,     array      >= 0.1 && < 0.6,-    pretty     >= 1   && < 1.2,-    bytestring >= 0.9+    base       >= 4.5 && < 5,+    bytestring >= 0.9 && < 1,+    containers >= 0.4 && < 0.6,+    deepseq    >= 1.3 && < 1.5,+    directory  >= 1.1 && < 1.3,+    filepath   >= 1.3 && < 1.5,+    pretty     >= 1.1 && < 1.2,+    process    >= 1.1.0.1 && < 1.5,+    time       >= 1.4 && < 1.7    if flag(bundled-binary-generic)     build-depends: binary >= 0.5 && < 0.7   else-    build-depends: binary >= 0.7 && < 0.8+    build-depends: binary >= 0.7 && < 0.9    -- Needed for GHC.Generics before GHC 7.6   if impl(ghc < 7.6)@@ -154,15 +236,24 @@    if !os(windows)     build-depends:-      unix >= 2.0 && < 2.8+      unix >= 2.5 && < 2.8 +  if os(windows)+    build-depends:+      Win32 >= 2.2 && < 2.4+   ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances+                 -Wnoncanonical-monadfail-instances    exposed-modules:     Distribution.Compat.CreatePipe     Distribution.Compat.Environment     Distribution.Compat.Exception+    Distribution.Compat.Internal.TempFile     Distribution.Compat.ReadP+    Distribution.Compat.Semigroup     Distribution.Compiler     Distribution.InstalledPackageInfo     Distribution.License@@ -232,16 +323,16 @@     Distribution.Verbosity     Distribution.Version     Language.Haskell.Extension+    Distribution.Compat.Binary    other-modules:-    Distribution.Compat.Binary     Distribution.Compat.CopyFile-    Distribution.Compat.TempFile+    Distribution.Compat.MonadFail     Distribution.GetOpt     Distribution.Lex     Distribution.Simple.GHC.Internal-    Distribution.Simple.GHC.IPI641     Distribution.Simple.GHC.IPI642+    Distribution.Simple.GHC.IPIConvert     Distribution.Simple.GHC.ImplInfo     Paths_Cabal @@ -251,25 +342,33 @@       Distribution.Compat.Binary.Generic    default-language: Haskell98-  default-extensions: CPP+  -- starting with GHC 7.0, rely on {-# LANGUAGE CPP #-} instead+  if !impl(ghc >= 7.0)+    default-extensions: CPP  -- Small, fast running tests. test-suite unit-tests   type: exitcode-stdio-1.0   hs-source-dirs: tests   other-modules:+    Test.Laws+    Test.QuickCheck.Utils     UnitTests.Distribution.Compat.CreatePipe     UnitTests.Distribution.Compat.ReadP     UnitTests.Distribution.Simple.Program.Internal+    UnitTests.Distribution.Simple.Utils+    UnitTests.Distribution.System     UnitTests.Distribution.Utils.NubList+    UnitTests.Distribution.Version   main-is: UnitTests.hs   build-depends:     base,+    directory,     tasty,     tasty-hunit,     tasty-quickcheck,     pretty,-    QuickCheck < 2.9,+    QuickCheck >= 2.7 && < 2.9,     Cabal   ghc-options: -Wall   default-language: Haskell98@@ -279,57 +378,28 @@   type: exitcode-stdio-1.0   main-is: PackageTests.hs   other-modules:-    PackageTests.BenchmarkExeV10.Check-    PackageTests.BenchmarkOptions.Check     PackageTests.BenchmarkStanza.Check-    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check-    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check-    PackageTests.BuildDeps.InternalLibrary0.Check-    PackageTests.BuildDeps.InternalLibrary1.Check-    PackageTests.BuildDeps.InternalLibrary2.Check-    PackageTests.BuildDeps.InternalLibrary3.Check-    PackageTests.BuildDeps.InternalLibrary4.Check-    PackageTests.BuildDeps.SameDepsAllRound.Check-    PackageTests.BuildDeps.TargetSpecificDeps1.Check-    PackageTests.BuildDeps.TargetSpecificDeps2.Check-    PackageTests.BuildDeps.TargetSpecificDeps3.Check-    PackageTests.CMain.Check-    PackageTests.DeterministicAr.Check-    PackageTests.EmptyLib.Check-    PackageTests.Haddock.Check-    PackageTests.OrderFlags.Check-    PackageTests.PackageTester-    PackageTests.PathsModule.Executable.Check-    PackageTests.PathsModule.Library.Check-    PackageTests.PreProcess.Check-    PackageTests.PreProcessExtraSources.Check-    PackageTests.ReexportedModules.Check-    PackageTests.TemplateHaskell.Check-    PackageTests.TestOptions.Check     PackageTests.TestStanza.Check+    PackageTests.DeterministicAr.Check     PackageTests.TestSuiteTests.ExeV10.Check-    PackageTests.TestSuiteTests.LibV09.Check-    Test.Distribution.Version-    Test.Laws-    Test.QuickCheck.Utils+    PackageTests.PackageTester   hs-source-dirs: tests   build-depends:     base,     containers,+    tagged,     tasty,-    tasty-quickcheck,     tasty-hunit,-    QuickCheck >= 2.1.0.1 && < 2.9,+    transformers,     Cabal,     process,     directory,     filepath,-    extensible-exceptions,     bytestring,     regex-posix,     old-time   if !os(windows)     build-depends: unix-  ghc-options: -Wall+  ghc-options: -Wall -rtsopts   default-extensions: CPP   default-language: Haskell98
cabal/Cabal/Distribution/Compat/Binary/Class.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE DefaultSignatures #-} -----------------------------------------------------------------------------@@ -53,13 +53,8 @@  import GHC.Generics ------ This isn't available in older Hugs or older GHC----#if __GLASGOW_HASKELL__ >= 606 import qualified Data.Sequence as Seq import qualified Data.Foldable as Fold-#endif  ------------------------------------------------------------------------ @@ -467,11 +462,6 @@ ------------------------------------------------------------------------ -- Queues and Sequences -#if __GLASGOW_HASKELL__ >= 606------ This is valid Hugs, but you need the most recent Hugs---- instance (Binary e) => Binary (Seq.Seq e) where     put s = put (Seq.length s) >> Fold.mapM_ put s     get = do n <- get :: Get Int@@ -480,8 +470,6 @@             rep xs n g = xs `seq` n `seq` do                            x <- g                            rep (xs Seq.|> x) (n-1) g--#endif  ------------------------------------------------------------------------ -- Floating point
cabal/Cabal/Distribution/Compat/CopyFile.hs view
@@ -11,24 +11,22 @@   setDirOrdinary,   ) where +import Distribution.Compat.Exception+import Distribution.Compat.Internal.TempFile  import Control.Monad          ( when, unless ) import Control.Exception-         ( bracket, bracketOnError, throwIO )+         ( bracketOnError, throwIO ) import qualified Data.ByteString.Lazy as BSL-import Distribution.Compat.Exception-         ( catchIO ) import System.IO.Error          ( ioeSetLocation ) import System.Directory          ( doesFileExist, renameFile, removeFile )-import Distribution.Compat.TempFile-         ( openBinaryTempFile ) import System.FilePath          ( takeDirectory ) import System.IO-         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf+         ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf          , withBinaryFile ) import Foreign          ( allocaBytes )@@ -69,7 +67,7 @@ copyFile fromFPath toFPath =   copy     `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))-    where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->+    where copy = withBinaryFile fromFPath ReadMode $ \hFrom ->                  bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->                  do allocaBytes bufferSize $ copyContents hFrom hTmp                     hClose hTmp@@ -100,8 +98,7 @@ filesEqual f1 f2 = do   ex1 <- doesFileExist f1   ex2 <- doesFileExist f2-  if not (ex1 && ex2) then return False else do-+  if not (ex1 && ex2) then return False else     withBinaryFile f1 ReadMode $ \h1 ->       withBinaryFile f2 ReadMode $ \h2 -> do         c1 <- BSL.hGetContents h1
+ cabal/Cabal/Distribution/Compat/Internal/TempFile.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Compat.Internal.TempFile (+  openTempFile,+  openBinaryTempFile,+  openNewBinaryFile,+  createTempDirectory,+  ) where++import Distribution.Compat.Exception++import System.FilePath        ((</>))+import Foreign.C              (CInt, eEXIST, getErrno, errnoToIOError)++import System.IO              (Handle, openTempFile, openBinaryTempFile)+import Data.Bits              ((.|.))+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,+                               o_BINARY, o_NONBLOCK, o_NOCTTY,+                               withFilePath, c_getpid)+import System.IO.Error        (isAlreadyExistsError)+import GHC.IO.Handle.FD       (fdToHandle)+import Control.Exception      (onException)++#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)+import System.Directory       ( createDirectory )+#else+import qualified System.Posix+#endif++-- ------------------------------------------------------------+-- * temporary files+-- ------------------------------------------------------------++-- This is here for Haskell implementations that do not come with+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.+-- TODO: Not sure about JHC+-- TODO: This file should probably be removed.++-- This is a copy/paste of the openBinaryTempFile definition, but+-- if uses 666 rather than 600 for the permissions. The base library+-- needs to be changed to make this better.+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)+openNewBinaryFile dir template = do+  pid <- c_getpid+  findTempName pid+  where+    -- We split off the last extension, so we can use .foo.ext files+    -- for temporary files (hidden on Unix OSes). Unfortunately we're+    -- below file path in the hierarchy here.+    (prefix,suffix) =+       case break (== '.') $ reverse template of+         -- First case: template contains no '.'s. Just re-reverse it.+         (rev_suffix, "")       -> (reverse rev_suffix, "")+         -- Second case: template contains at least one '.'. Strip the+         -- dot from the prefix and prepend it to the suffix (if we don't+         -- do this, the unique number will get added after the '.' and+         -- thus be part of the extension, which is wrong.)+         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)+         -- Otherwise, something is wrong, because (break (== '.')) should+         -- always return a pair with either the empty string or a string+         -- beginning with '.' as the second component.+         _                      -> error "bug in System.IO.openTempFile"++    oflags = rw_flags .|. o_EXCL .|. o_BINARY++    findTempName x = do+      fd <- withFilePath filepath $ \ f ->+              c_open f oflags 0o666+      if fd < 0+       then do+         errno <- getErrno+         if errno == eEXIST+           then findTempName (x+1)+           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))+       else do+         -- TODO: We want to tell fdToHandle what the file path is,+         -- as any exceptions etc will only be able to report the+         -- FD currently+         h <- fdToHandle fd `onException` c_close fd+         return (filepath, h)+      where+        filename        = prefix ++ show x ++ suffix+        filepath        = dir `combine` filename++        -- FIXME: bits copied from System.FilePath+        combine a b+                  | null b = a+                  | null a = b+                  | last a == pathSeparator = a ++ b+                  | otherwise = a ++ [pathSeparator] ++ b++-- FIXME: Should use System.FilePath library+pathSeparator :: Char+#ifdef mingw32_HOST_OS+pathSeparator = '\\'+#else+pathSeparator = '/'+#endif++-- FIXME: Copied from GHC.Handle+std_flags, output_flags, rw_flags :: CInt+std_flags    = o_NONBLOCK   .|. o_NOCTTY+output_flags = std_flags    .|. o_CREAT+rw_flags     = output_flags .|. o_RDWR++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir template = do+  pid <- c_getpid+  findTempName pid+  where+    findTempName x = do+      let dirpath = dir </> template ++ "-" ++ show x+      r <- tryIO $ mkPrivateDir dirpath+      case r of+        Right _ -> return dirpath+        Left  e | isAlreadyExistsError e -> findTempName (x+1)+                | otherwise              -> ioError e++mkPrivateDir :: String -> IO ()+#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)+mkPrivateDir s = createDirectory s+#else+mkPrivateDir s = System.Posix.createDirectory s 0o700+#endif
+ cabal/Cabal/Distribution/Compat/MonadFail.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}++-- | Compatibility layer for "Control.Monad.Fail"+module Distribution.Compat.MonadFail ( MonadFail(fail) ) where+#if __GLASGOW_HASKELL__ >= 800+-- provided by base-4.9.0.0 and later+import Control.Monad.Fail (MonadFail(fail))+#else+-- the following code corresponds to+-- http://hackage.haskell.org/package/fail-4.9.0.0+import qualified Prelude as P+import Prelude hiding (fail)++import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadPrec++class Monad m => MonadFail m where+    fail :: String -> m a++-- instances provided by base-4.9++instance MonadFail Maybe where+    fail _ = Nothing++instance MonadFail [] where+    fail _ = []++instance MonadFail IO where+    fail = P.fail++instance MonadFail ReadPrec where+    fail = P.fail -- = P (\_ -> fail s)++instance MonadFail ReadP where+    fail = P.fail+#endif
cabal/Cabal/Distribution/Compat/ReadP.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compat.ReadP@@ -70,12 +69,11 @@   )  where -import Control.Monad( MonadPlus(..), liftM, liftM2, ap )+import qualified Distribution.Compat.MonadFail as Fail++import Control.Monad( MonadPlus(..), liftM, liftM2, replicateM, ap, (>=>) ) import Data.Char (isSpace)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Applicative (Alternative(empty, (<|>)))+import Control.Applicative as AP (Applicative(..), Alternative(empty, (<|>)))  infixr 5 +++, <++ @@ -96,18 +94,21 @@   fmap = liftM  instance Applicative (P s) where-  pure = return+  pure x = Result x Fail   (<*>) = ap  instance Monad (P s) where-  return x = Result x Fail+  return = AP.pure -  (Get f)      >>= k = Get (\c -> f c >>= k)-  (Look f)     >>= k = Look (\s -> f s >>= k)+  (Get f)      >>= k = Get (f >=> k)+  (Look f)     >>= k = Look (f >=> k)   Fail         >>= _ = Fail   (Result x p) >>= k = k x `mplus` (p >>= k)   (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] +  fail = Fail.fail++instance Fail.MonadFail (P s) where   fail _ = Fail  instance Alternative (P s) where@@ -155,14 +156,17 @@   fmap h (R f) = R (\k -> f (k . h))  instance Applicative (Parser r s) where-  pure = return+  pure x  = R (\k -> k x)   (<*>) = ap  instance Monad (Parser r s) where-  return x  = R (\k -> k x)-  fail _    = R (\_ -> Fail)+  return = AP.pure+  fail = Fail.fail   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) +instance Fail.MonadFail (Parser r s) where+  fail _    = R (const Fail)+ --instance MonadPlus (Parser r s) where --  mzero = pfail --  mplus = (+++)@@ -197,7 +201,7 @@  pfail :: ReadP r a -- ^ Always fails.-pfail = R (\_ -> Fail)+pfail = R (const Fail)  (+++) :: ReadP r a -> ReadP r a -> ReadP r a -- ^ Symmetric choice.@@ -230,7 +234,7 @@  where   gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))   gath _ Fail         = Fail-  gath l (Look f)     = Look (\s -> gath l (f s))+  gath l (Look f)     = Look (gath l . f)   gath l (Result k p) = k (l []) `mplus` gath l p   gath _ (Final _)    = error "do not use readS_to_P in gather!" @@ -250,9 +254,9 @@ -- ^ Parses and returns the specified string. string this = do s <- look; scan this s  where-  scan []     _               = do return this-  scan (x:xs) (y:ys) | x == y = do get >> scan xs ys-  scan _      _               = do pfail+  scan []     _               = return this+  scan (x:xs) (y:ys) | x == y = get >> scan xs ys+  scan _      _               = pfail  munch :: (Char -> Bool) -> ReadP r String -- ^ Parses the first zero or more characters satisfying the predicate.@@ -288,7 +292,7 @@ count :: Int -> ReadP r a -> ReadP r [a] -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of --   results is returned.-count n p = sequence (replicate n p)+count n p = replicateM n p  between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a -- ^ @ between open close p @ parses @open@, followed by @p@ and finally
+ cabal/Cabal/Distribution/Compat/Semigroup.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP                         #-}+{-# LANGUAGE DeriveGeneric               #-}+{-# LANGUAGE FlexibleContexts            #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE TypeOperators               #-}++-- | Compatibility layer for "Data.Semigroup"+module Distribution.Compat.Semigroup+    ( Semigroup((<>))+    , Mon.Monoid(..)+    , All(..)+    , Any(..)++    , Last'(..)++    , gmappend+    , gmempty+    ) where++import Distribution.Compat.Binary (Binary)++import Control.Applicative as App+import GHC.Generics+#if __GLASGOW_HASKELL__ >= 711+-- Data.Semigroup is available since GHC 8.0/base-4.9+import Data.Semigroup+import qualified Data.Monoid as Mon+#else+-- provide internal simplified non-exposed class for older GHCs+import Data.Monoid as Mon (Monoid(..), All(..), Any(..), Dual(..))+-- containers+import Data.Set (Set)+import Data.IntSet (IntSet)+import Data.Map (Map)+import Data.IntMap (IntMap)+++class Semigroup a where+    (<>) :: a -> a -> a++-- several primitive instances+instance Semigroup () where+    _ <> _ = ()++instance Semigroup [a] where+    (<>) = (++)++instance Semigroup a => Semigroup (Dual a) where+    Dual a <> Dual b = Dual (b <> a)++instance Semigroup a => Semigroup (Maybe a) where+    Nothing <> b       = b+    a       <> Nothing = a+    Just a  <> Just b  = Just (a <> b)++instance Semigroup (Either a b) where+    Left _ <> b = b+    a      <> _ = a++instance Semigroup Ordering where+    LT <> _ = LT+    EQ <> y = y+    GT <> _ = GT++instance Semigroup b => Semigroup (a -> b) where+    f <> g = \a -> f a <> g a++instance Semigroup All where+    All a <> All b = All (a && b)++instance Semigroup Any where+    Any a <> Any b = Any (a || b)++instance (Semigroup a, Semigroup b) => Semigroup (a, b) where+    (a,b) <> (a',b') = (a<>a',b<>b')++instance (Semigroup a, Semigroup b, Semigroup c)+         => Semigroup (a, b, c) where+    (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)+         => Semigroup (a, b, c, d) where+    (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')++instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)+         => Semigroup (a, b, c, d, e) where+    (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')++-- containers instances+instance Semigroup IntSet where+  (<>) = mappend++instance Ord a => Semigroup (Set a) where+  (<>) = mappend++instance Semigroup (IntMap v) where+  (<>) = mappend++instance Ord k => Semigroup (Map k v) where+  (<>) = mappend+#endif++-- | Cabal's own 'Data.Monoid.Last' copy to avoid requiring an orphan+-- 'Binary' instance.+--+-- Once the oldest `binary` version we support provides a 'Binary'+-- instance for 'Data.Monoid.Last' we can remove this one here.+--+-- NB: 'Data.Semigroup.Last' is defined differently and not a 'Monoid'+newtype Last' a = Last' { getLast' :: Maybe a }+                deriving (Eq, Ord, Read, Show, Binary,+                          Functor, App.Applicative, Generic)++instance Semigroup (Last' a) where+    x <> Last' Nothing = x+    _ <> x             = x++instance Monoid (Last' a) where+    mempty = Last' Nothing+    mappend = (<>)++-------------------------------------------------------------------------------+-------------------------------------------------------------------------------+-- Stolen from Edward Kmett's BSD3-licensed `semigroups` package++-- | Generically generate a 'Semigroup' ('<>') operation for any type+-- implementing 'Generic'. This operation will append two values+-- by point-wise appending their component fields. It is only defined+-- for product types.+--+-- @+-- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c+-- @+gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a+gmappend x y = to (gmappend' (from x) (from y))++class GSemigroup f where+    gmappend' :: f p -> f p -> f p++instance Semigroup a => GSemigroup (K1 i a) where+    gmappend' (K1 x) (K1 y) = K1 (x <> y)++instance GSemigroup f => GSemigroup (M1 i c f) where+    gmappend' (M1 x) (M1 y) = M1 (gmappend' x y)++instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where+    gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2++-- | Generically generate a 'Monoid' 'mempty' for any product-like type+-- implementing 'Generic'.+--+-- It is only defined for product types.+--+-- @+-- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty'+-- @++gmempty :: (Generic a, GMonoid (Rep a)) => a+gmempty = to gmempty'++class GSemigroup f => GMonoid f where+    gmempty' :: f p++instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where+    gmempty' = K1 mempty++instance GMonoid f => GMonoid (M1 i c f) where+    gmempty' = M1 gmempty'++instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where+    gmempty' = gmempty' :*: gmempty'
− cabal/Cabal/Distribution/Compat/TempFile.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.TempFile (-  openTempFile,-  openBinaryTempFile,-  openNewBinaryFile,-  createTempDirectory,-  ) where---import System.FilePath        ((</>))-import Foreign.C              (eEXIST)--import System.IO              (Handle, openTempFile, openBinaryTempFile)-import Data.Bits              ((.|.))-import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,-                               o_BINARY, o_NONBLOCK, o_NOCTTY)-import System.IO.Error        (isAlreadyExistsError)-import System.Posix.Internals (withFilePath)-import Foreign.C              (CInt)-import GHC.IO.Handle.FD       (fdToHandle)-import Distribution.Compat.Exception (tryIO)-import Control.Exception      (onException)-import Foreign.C              (getErrno, errnoToIOError)--import System.Posix.Internals (c_getpid)--#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)-import System.Directory       ( createDirectory )-#else-import qualified System.Posix-#endif---- --------------------------------------------------------------- * temporary files--- ---------------------------------------------------------------- This is here for Haskell implementations that do not come with--- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.--- TODO: Not sure about JHC--- TODO: This file should probably be removed.---- This is a copy/paste of the openBinaryTempFile definition, but--- if uses 666 rather than 600 for the permissions. The base library--- needs to be changed to make this better.-openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)-openNewBinaryFile dir template = do-  pid <- c_getpid-  findTempName pid-  where-    -- We split off the last extension, so we can use .foo.ext files-    -- for temporary files (hidden on Unix OSes). Unfortunately we're-    -- below file path in the hierarchy here.-    (prefix,suffix) =-       case break (== '.') $ reverse template of-         -- First case: template contains no '.'s. Just re-reverse it.-         (rev_suffix, "")       -> (reverse rev_suffix, "")-         -- Second case: template contains at least one '.'. Strip the-         -- dot from the prefix and prepend it to the suffix (if we don't-         -- do this, the unique number will get added after the '.' and-         -- thus be part of the extension, which is wrong.)-         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)-         -- Otherwise, something is wrong, because (break (== '.')) should-         -- always return a pair with either the empty string or a string-         -- beginning with '.' as the second component.-         _                      -> error "bug in System.IO.openTempFile"--    oflags = rw_flags .|. o_EXCL .|. o_BINARY--    findTempName x = do-      fd <- withFilePath filepath $ \ f ->-              c_open f oflags 0o666-      if fd < 0-       then do-         errno <- getErrno-         if errno == eEXIST-           then findTempName (x+1)-           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))-       else do-         -- TODO: We want to tell fdToHandle what the file path is,-         -- as any exceptions etc will only be able to report the-         -- FD currently-         h <- fdToHandle fd `onException` c_close fd-         return (filepath, h)-      where-        filename        = prefix ++ show x ++ suffix-        filepath        = dir `combine` filename--        -- FIXME: bits copied from System.FilePath-        combine a b-                  | null b = a-                  | null a = b-                  | last a == pathSeparator = a ++ b-                  | otherwise = a ++ [pathSeparator] ++ b---- FIXME: Should use System.FilePath library-pathSeparator :: Char-#ifdef mingw32_HOST_OS-pathSeparator = '\\'-#else-pathSeparator = '/'-#endif---- FIXME: Copied from GHC.Handle-std_flags, output_flags, rw_flags :: CInt-std_flags    = o_NONBLOCK   .|. o_NOCTTY-output_flags = std_flags    .|. o_CREAT-rw_flags     = output_flags .|. o_RDWR--createTempDirectory :: FilePath -> String -> IO FilePath-createTempDirectory dir template = do-  pid <- c_getpid-  findTempName pid-  where-    findTempName x = do-      let dirpath = dir </> template ++ "-" ++ show x-      r <- tryIO $ mkPrivateDir dirpath-      case r of-        Right _ -> return dirpath-        Left  e | isAlreadyExistsError e -> findTempName (x+1)-                | otherwise              -> ioError e--mkPrivateDir :: String -> IO ()-#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)-mkPrivateDir s = createDirectory s-#else-mkPrivateDir s = System.Posix.createDirectory s 0o700-#endif
cabal/Cabal/Distribution/Compiler.hs view
@@ -42,15 +42,15 @@   AbiTag(..), abiTagString   ) where -import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Binary+import Language.Haskell.Extension+ import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe) import Distribution.Version (Version(..)) import GHC.Generics (Generic) -import Language.Haskell.Extension (Language, Extension)- import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse@@ -180,7 +180,7 @@ data AbiTag   = NoAbiTag   | AbiTag String-  deriving (Generic, Show, Read)+  deriving (Eq, Generic, Show, Read)  instance Binary AbiTag
cabal/Cabal/Distribution/InstalledPackageInfo.hs view
@@ -28,8 +28,9 @@  module Distribution.InstalledPackageInfo (         InstalledPackageInfo(..),-        libraryName,-        OriginalModule(..), ExposedModule(..),+        installedComponentId,+        installedPackageId,+        ExposedModule(..),         ParseResult(..), PError(..), PWarning,         emptyInstalledPackageInfo,         parseInstalledPackageInfo,@@ -40,43 +41,30 @@   ) where  import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), PError(..), PWarning-         , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, showSimpleSingleNamedField-         , parseFieldsFlat-         , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ-         , showFilePath, showToken, boolField, parseOptVersion-         , parseFreeText, showFreeText, parseOptCommaList )-import Distribution.License     ( License(..) )-import Distribution.Package-         ( PackageName(..), PackageIdentifier(..)-         , PackageId, InstalledPackageId(..)-         , packageName, packageVersion, PackageKey(..)-         , LibraryName(..) )+import Distribution.License+import Distribution.Package hiding (installedUnitId, installedPackageId) import qualified Distribution.Package as Package import Distribution.ModuleName-         ( ModuleName ) import Distribution.Version-         ( Version(..) ) import Distribution.Text-         ( Text(disp, parse) )-import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.Binary -import Distribution.Compat.Binary  (Binary)+import Text.PrettyPrint as Disp import Data.Maybe   (fromMaybe) import GHC.Generics (Generic)  -- ----------------------------------------------------------------------------- -- The InstalledPackageInfo type -+-- For BC reasons, we continue to name this record an InstalledPackageInfo;+-- but it would more accurately be called an InstalledUnitInfo with Backpack data InstalledPackageInfo    = InstalledPackageInfo {         -- these parts are exactly the same as PackageDescription-        installedPackageId :: InstalledPackageId,-        sourcePackageId    :: PackageId,-        packageKey         :: PackageKey,+        sourcePackageId   :: PackageId,+        installedUnitId   :: UnitId,+        compatPackageKey  :: String,         license           :: License,         copyright         :: String,         maintainer        :: String,@@ -88,9 +76,9 @@         description       :: String,         category          :: String,         -- these parts are required by an installed package only:+        abiHash           :: AbiHash,         exposed           :: Bool,         exposedModules    :: [ExposedModule],-        instantiatedWith  :: [(ModuleName, OriginalModule)],         hiddenModules     :: [ModuleName],         trusted           :: Bool,         importDirs        :: [FilePath],@@ -101,7 +89,7 @@         extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi         includeDirs       :: [FilePath],         includes          :: [String],-        depends           :: [InstalledPackageId],+        depends           :: [UnitId],         ccOptions         :: [String],         ldOptions         :: [String],         frameworkDirs     :: [FilePath],@@ -110,18 +98,24 @@         haddockHTMLs      :: [FilePath],         pkgRoot           :: Maybe FilePath     }-    deriving (Generic, Read, Show)+    deriving (Eq, Generic, Read, Show) -libraryName :: InstalledPackageInfo -> LibraryName-libraryName ipi = Package.packageKeyLibraryName (sourcePackageId ipi) (packageKey ipi)+installedComponentId :: InstalledPackageInfo -> ComponentId+installedComponentId ipi = case installedUnitId ipi of+                            SimpleUnitId cid -> cid +{-# DEPRECATED installedPackageId "Use installedUnitId instead" #-}+-- | Backwards compatibility with Cabal pre-1.24.+installedPackageId :: InstalledPackageInfo -> UnitId+installedPackageId = installedUnitId+ instance Binary InstalledPackageInfo  instance Package.Package InstalledPackageInfo where    packageId = sourcePackageId -instance Package.HasInstalledPackageId InstalledPackageInfo where-   installedPackageId = installedPackageId+instance Package.HasUnitId InstalledPackageInfo where+   installedUnitId = installedUnitId  instance Package.PackageInstalled InstalledPackageInfo where    installedDepends = depends@@ -129,10 +123,9 @@ emptyInstalledPackageInfo :: InstalledPackageInfo emptyInstalledPackageInfo    = InstalledPackageInfo {-        installedPackageId = InstalledPackageId "",-        sourcePackageId    = PackageIdentifier (PackageName "") noVersion,-        packageKey         = OldPackageKey (PackageIdentifier-                                               (PackageName "") noVersion),+        sourcePackageId   = PackageIdentifier (PackageName "") (Version [] []),+        installedUnitId   = mkUnitId "",+        compatPackageKey  = "",         license           = UnspecifiedLicense,         copyright         = "",         maintainer        = "",@@ -143,10 +136,10 @@         synopsis          = "",         description       = "",         category          = "",+        abiHash           = AbiHash "",         exposed           = False,         exposedModules    = [],         hiddenModules     = [],-        instantiatedWith  = [],         trusted           = False,         importDirs        = [],         libraryDirs       = [],@@ -166,45 +159,22 @@         pkgRoot           = Nothing     } -noVersion :: Version-noVersion = Version [] []- -- ----------------------------------------------------------------------------- -- Exposed modules -data OriginalModule-   = OriginalModule {-       originalPackageId :: InstalledPackageId,-       originalModuleName :: ModuleName-     }-  deriving (Generic, Eq, Read, Show)- data ExposedModule    = ExposedModule {        exposedName      :: ModuleName,-       exposedReexport  :: Maybe OriginalModule,-       exposedSignature :: Maybe OriginalModule -- This field is unused for now.+       exposedReexport  :: Maybe Module      }-  deriving (Generic, Read, Show)--instance Text OriginalModule where-    disp (OriginalModule ipi m) =-        disp ipi <> Disp.char ':' <> disp m-    parse = do-        ipi <- parse-        _ <- Parse.char ':'-        m <- parse-        return (OriginalModule ipi m)+  deriving (Eq, Generic, Read, Show)  instance Text ExposedModule where-    disp (ExposedModule m reexport signature) =+    disp (ExposedModule m reexport) =         Disp.sep [ disp m                  , case reexport of                     Just m' -> Disp.sep [Disp.text "from", disp m']                     Nothing -> Disp.empty-                 , case signature of-                    Just m' -> Disp.sep [Disp.text "is", disp m']-                    Nothing -> Disp.empty                  ]     parse = do         m <- parseModuleNameQ@@ -213,16 +183,9 @@             _ <- Parse.string "from"             Parse.skipSpaces             fmap Just parse-        Parse.skipSpaces-        signature <- Parse.option Nothing $ do-            _ <- Parse.string "is"-            Parse.skipSpaces-            fmap Just parse-        return (ExposedModule m reexport signature)+        return (ExposedModule m reexport)  -instance Binary OriginalModule- instance Binary ExposedModule  -- To maintain backwards-compatibility, we accept both comma/non-comma@@ -234,7 +197,7 @@ showExposedModules xs     | all isExposedModule xs = fsep (map disp xs)     | otherwise = fsep (Disp.punctuate comma (map disp xs))-    where isExposedModule (ExposedModule _ Nothing Nothing) = True+    where isExposedModule (ExposedModule _ Nothing) = True           isExposedModule _ = False  parseExposedModules :: Parse.ReadP r [ExposedModule]@@ -248,14 +211,6 @@     parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)     emptyInstalledPackageInfo -parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule)-parseInstantiatedWith = do k <- parse-                           _ <- Parse.char '='-                           n <- parse-                           _ <- Parse.char '@'-                           p <- parse-                           return (k, OriginalModule p n)- -- ----------------------------------------------------------------------------- -- Pretty-printing @@ -268,9 +223,6 @@ showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo -showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc-showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p- -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing @@ -287,10 +239,11 @@                            packageVersion         (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})  , simpleField "id"                            disp                   parse-                           installedPackageId     (\ipid pkg -> pkg{installedPackageId=ipid})+                           installedUnitId             (\pk pkg -> pkg{installedUnitId=pk})+ -- NB: parse these as component IDs  , simpleField "key"-                           disp                   parse-                           packageKey             (\pk pkg -> pkg{packageKey=pk})+                           (disp . ComponentId)   (fmap (\(ComponentId s) -> s) parse)+                           compatPackageKey       (\pk pkg -> pkg{compatPackageKey=pk})  , simpleField "license"                            disp                   parseLicenseQ                            license                (\l pkg -> pkg{license=l})@@ -333,9 +286,9 @@  , listField   "hidden-modules"         disp               parseModuleNameQ         hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})- , listField   "instantiated-with"-        showInstantiatedWith parseInstantiatedWith-        instantiatedWith   (\xs    pkg -> pkg{instantiatedWith=xs})+ , simpleField "abi"+        disp               parse+        abiHash            (\abi    pkg -> pkg{abiHash=abi})  , boolField   "trusted"         trusted            (\val pkg -> pkg{trusted=val})  , listField   "import-dirs"
cabal/Cabal/Distribution/Lex.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- |@@ -15,9 +14,7 @@  ) where  import Data.Char (isSpace)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif+import Distribution.Compat.Semigroup as Semi  newtype DList a = DList ([a] -> [a]) @@ -29,7 +26,10 @@  instance Monoid (DList a) where   mempty = DList id-  DList a `mappend` DList b = DList (a . b)+  mappend = (Semi.<>)++instance Semigroup (DList a) where+  DList a <> DList b = DList (a . b)  tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty
cabal/Cabal/Distribution/License.hs view
@@ -47,13 +47,13 @@     knownLicenses,   ) where -import Distribution.Version (Version(Version))--import Distribution.Text (Text(..), display)+import Distribution.Version+import Distribution.Text import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.Binary+ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>))-import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char (isAlphaNum) import Data.Data (Data) import Data.Typeable (Typeable)
cabal/Cabal/Distribution/Make.hs view
@@ -62,22 +62,19 @@  -- local import Distribution.Compat.Exception-import Distribution.Package --must not specify imports, since we're exporting moule.-import Distribution.Simple.Program(defaultProgramConfiguration)+import Distribution.Package+import Distribution.Simple.Program import Distribution.PackageDescription import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Utils (rawSystemExit, cabalVersion)+import Distribution.Simple.Utils -import Distribution.License (License(..))+import Distribution.License import Distribution.Version-         ( Version(..) ) import Distribution.Text-         ( display )  import System.Environment (getArgs, getProgName)-import Data.List  (intercalate) import System.Exit  defaultMain :: IO ()
cabal/Cabal/Distribution/ModuleName.hs view
@@ -22,14 +22,14 @@   ) where  import Distribution.Text-         ( Text(..) )+import Distribution.Compat.Binary+import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char          ( isAlphaNum, isUpper )+import Control.DeepSeq import Data.Data (Data) import Data.Typeable (Typeable)-import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Data.List          ( intercalate, intersperse )@@ -43,6 +43,9 @@   deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)  instance Binary ModuleName++instance NFData ModuleName where+    rnf (ModuleName ms) = rnf ms  instance Text ModuleName where   disp (ModuleName ms) =
cabal/Cabal/Distribution/Package.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  ----------------------------------------------------------------------------- -- |@@ -21,19 +22,19 @@         PackageIdentifier(..),         PackageId, -        -- * Installed package identifiers-        InstalledPackageId(..),+        -- * Package keys/installed package IDs (used for linker symbols)+        ComponentId(..),+        UnitId(..),+        mkUnitId,+        mkLegacyUnitId,+        getHSLibraryName,+        InstalledPackageId, -- backwards compat -        -- * Package keys (used for linker symbols)-        PackageKey(..),-        mkPackageKey,-        packageKeyHash,-        packageKeyLibraryName,+        -- * Modules+        Module(..), -        -- * Library name (used for install path, package key)-        LibraryName(..),-        emptyLibraryName,-        getHSLibraryName,+        -- * ABI hash+        AbiHash(..),          -- * Package source dependencies         Dependency(..),@@ -43,7 +44,8 @@          -- * Package classes         Package(..), packageName, packageVersion,-        HasInstalledPackageId(..),+        HasUnitId(..),+        installedPackageId,         PackageInstalled(..),   ) where @@ -51,22 +53,20 @@          ( Version(..), VersionRange, anyVersion, thisVersion          , notThisVersion, simplifyVersionRange ) -import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((<++)) import qualified Text.PrettyPrint as Disp+import Distribution.Compat.ReadP+import Distribution.Compat.Binary+import Distribution.Text+import Distribution.ModuleName  import Control.DeepSeq (NFData(..))-import Distribution.Compat.Binary (Binary) import qualified Data.Char as Char-    ( isDigit, isAlphaNum, isUpper, isLower, ord, chr )+    ( isDigit, isAlphaNum, ) import Data.Data ( Data )-import Data.List ( intercalate, foldl', sort )+import Data.List ( intercalate ) import Data.Typeable ( Typeable )-import Data.Word ( Word64 )-import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) import GHC.Generics (Generic)-import Numeric ( showIntAtBase ) import Text.PrettyPrint ((<>), (<+>), text)  newtype PackageName = PackageName { unPackageName :: String }@@ -115,190 +115,72 @@ instance NFData PackageIdentifier where     rnf (PackageIdentifier name version) = rnf name `seq` rnf version --- --------------------------------------------------------------- * Installed Package Ids--- ---------------------------------------------------------------- | An InstalledPackageId uniquely identifies an instance of an installed--- package.  There can be at most one package with a given 'InstalledPackageId'--- in a package database, or overlay of databases.----newtype InstalledPackageId = InstalledPackageId String- deriving (Generic, Read,Show,Eq,Ord,Typeable,Data)--instance Binary InstalledPackageId+-- | A module identity uniquely identifies a Haskell module by+-- qualifying a 'ModuleName' with the 'UnitId' which defined+-- it.  This type distinguishes between two packages+-- which provide a module with the same name, or a module+-- from the same package compiled with different dependencies.+-- There are a few cases where Cabal needs to know about+-- module identities, e.g., when writing out reexported modules in+-- the 'InstalledPackageInfo'.+data Module =+    Module { moduleUnitId :: UnitId,+             moduleName :: ModuleName }+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -instance Text InstalledPackageId where-  disp (InstalledPackageId str) = text str+instance Binary Module -  parse = InstalledPackageId `fmap` Parse.munch1 abi_char-   where abi_char c = Char.isAlphaNum c || c `elem` "-_."+instance Text Module where+    disp (Module uid mod_name) =+        disp uid <> Disp.text ":" <> disp mod_name+    parse = do+        uid <- parse+        _ <- Parse.char ':'+        mod_name <- parse+        return (Module uid mod_name) --- --------------------------------------------------------------- * Package Keys--- ------------------------------------------------------------+instance NFData Module where+    rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name --- | A 'PackageKey' is the notion of "package ID" which is visible to the--- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible--- concept written explicity in Cabal files; on the other hand, a 'PackageKey'--- may contain, for example, information about the transitive dependency--- tree of a package.  Why is this not an 'InstalledPackageId'?  A 'PackageKey'--- should be stable so that we can incrementally recompile after a source edit;--- however, an 'InstalledPackageId' may change even with source.------ Package keys may be generated either by Cabal or GHC.  In particular,--- ordinary, "old-style" packages which don't use Backpack features can--- have their package keys generated directly by Cabal and coincide with--- 'LibraryName's.  However, Backpack keys are generated by GHC may exhibit--- more variation than a 'LibraryName'.+-- | A 'ComponentId' uniquely identifies the transitive source+-- code closure of a component.  For non-Backpack components, it also+-- serves as the basis for install paths, symbols, etc. ---data PackageKey-    -- | Modern package key which is a hash of the PackageId and the transitive-    -- dependency key.  It's manually inlined here so we can get the instances-    -- we need.  There's an optional prefix for compatibility with GHC 7.10.-    = PackageKey (Maybe String) {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-    -- | Old-style package key which is just a 'PackageId'.  Required because-    -- old versions of GHC assume that the 'sourcePackageId' recorded for an-    -- installed package coincides with the package key it was compiled with.-    | OldPackageKey !PackageId+data ComponentId+    = ComponentId String     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) -instance Binary PackageKey---- | Convenience function which converts a fingerprint into a new-style package--- key.-fingerprintPackageKey :: Fingerprint -> PackageKey-fingerprintPackageKey (Fingerprint a b) = PackageKey Nothing a b---- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the--- immediate dependencies.-mkPackageKey :: Bool -- are modern style package keys supported?-             -> PackageId-             -> [LibraryName] -- dependencies-             -> PackageKey-mkPackageKey True pid deps =-    fingerprintPackageKey . fingerprintString $-        display pid ++ "\n" ++-        concat [ display dep ++ "\n" | dep <- sort deps ]-mkPackageKey False pid _ = OldPackageKey pid---- The base-62 code is based off of 'locators'--- ((c) Operational Dynamics Consulting, BSD3 licensed)---- Note: Instead of base-62 encoding a single 128-bit integer--- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers--- (2 * ceil(10.75) characters).  Luckily for us, it's the same number of--- characters!  In the long term, this should go in GHC.Fingerprint,--- but not now...---- | Size of a 64-bit word when written as a base-62 string-word64Base62Len :: Int-word64Base62Len = 11---- | Converts a 64-bit word into a base-62 string-toBase62 :: Word64 -> String-toBase62 w = pad ++ str-  where-    pad = replicate len '0'-    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)-    str = showIntAtBase 62 represent w ""-    represent :: Int -> Char-    represent x-        | x < 10 = Char.chr (48 + x)-        | x < 36 = Char.chr (65 + x - 10)-        | x < 62 = Char.chr (97 + x - 36)-        | otherwise = error ("represent (base 62): impossible!")---- | Parses a base-62 string into a 64-bit word-fromBase62 :: String -> Word64-fromBase62 ss = foldl' multiply 0 ss-  where-    value :: Char -> Int-    value c-        | Char.isDigit c = Char.ord c - 48-        | Char.isUpper c = Char.ord c - 65 + 10-        | Char.isLower c = Char.ord c - 97 + 36-        | otherwise = error ("value (base 62): impossible!")--    multiply :: Word64 -> Char -> Word64-    multiply acc c = acc * 62 + (fromIntegral $ value c)---- | Parses a base-62 string into a fingerprint.-readBase62Fingerprint :: String -> Fingerprint-readBase62Fingerprint s = Fingerprint w1 w2- where (s1,s2) = splitAt word64Base62Len s-       w1 = fromBase62 s1-       w2 = fromBase62 (take word64Base62Len s2)---- | Compute the hash (without a prefix) of a package key.  In GHC 7.12--- this is equivalent to display.-packageKeyHash :: PackageKey -> String-packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2-packageKeyHash (OldPackageKey pid) = display pid---- | Legacy function for GHC 7.10 to compute a LibraryName based on--- the package key.-packageKeyLibraryName :: PackageId -> PackageKey -> LibraryName-packageKeyLibraryName pid (PackageKey _ w1 w2) =-  LibraryName (display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2)-packageKeyLibraryName _ (OldPackageKey pid) = LibraryName (display pid)--instance Text PackageKey where-  disp (PackageKey mb_prefix w1 w2)-    = maybe Disp.empty (\r -> Disp.text r <> Disp.char '_') mb_prefix <>-      Disp.text (toBase62 w1) <> Disp.text (toBase62 w2)-  disp (OldPackageKey pid) = disp pid--  parse = parseNewWithAnnot <++ parseNew <++ parseOld-    where parseNew = do-            fmap (fingerprintPackageKey . readBase62Fingerprint)-                . Parse.count (word64Base62Len * 2)-                $ Parse.satisfy Char.isAlphaNum-          parseNewWithAnnot = do-            -- this is ignored-            prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-")-            _ <- Parse.char '_' -- if we use '-' it's ambiguous-            PackageKey _ w1 w2 <- parseNew-            return (PackageKey (Just prefix) w1 w2)-          parseOld = do pid <- parse-                        return (OldPackageKey pid)--instance NFData PackageKey where-    rnf (PackageKey mb _ _) = rnf mb-    rnf (OldPackageKey pid) = rnf pid+{-# DEPRECATED InstalledPackageId "Use UnitId instead" #-}+type InstalledPackageId = UnitId --- --------------------------------------------------------------- * Library names--- ------------------------------------------------------------+instance Binary ComponentId --- | A library name consists of not only a source package--- id ('PackageId') but also the library names of all textual--- dependencies; thus, a library name uniquely identifies an--- installed package up to the dependency resolution done by Cabal.--- Create using 'packageKeyLibraryName'.  Library names are opaque,--- Cabal-defined strings.-newtype LibraryName-    = LibraryName String-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)+instance Text ComponentId where+  disp (ComponentId str) = text str -instance Binary LibraryName+  parse = ComponentId `fmap` Parse.munch1 abi_char+   where abi_char c = Char.isAlphaNum c || c `elem` "-_." --- | Default library name for when it is not known.-emptyLibraryName :: LibraryName-emptyLibraryName = LibraryName ""+instance NFData ComponentId where+    rnf (ComponentId pk) = rnf pk  -- | Returns library name prefixed with HS, suitable for filenames-getHSLibraryName :: LibraryName -> String-getHSLibraryName (LibraryName s) = "HS" ++ s+getHSLibraryName :: UnitId -> String+getHSLibraryName (SimpleUnitId (ComponentId s)) = "HS" ++ s -instance Text LibraryName where-    disp (LibraryName s) = Disp.text s-    parse = LibraryName `fmap` Parse.munch1 hash_char-        where hash_char c = Char.isAlphaNum c || c `elem` "-_."+-- | For now, there is no distinction between component IDs+-- and unit IDs in Cabal.+newtype UnitId = SimpleUnitId ComponentId+    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, Text, NFData) -instance NFData LibraryName where-    rnf (LibraryName s) = rnf s+-- | Makes a simple-style UnitId from a string.+mkUnitId :: String -> UnitId+mkUnitId = SimpleUnitId . ComponentId +-- | Make an old-style UnitId from a package identifier+mkLegacyUnitId :: PackageId -> UnitId+mkLegacyUnitId = SimpleUnitId . ComponentId . display+ -- ------------------------------------------------------------ -- * Package source dependencies -- ------------------------------------------------------------@@ -358,14 +240,30 @@   packageId = id  -- | Packages that have an installed package ID-class Package pkg => HasInstalledPackageId pkg where-  installedPackageId :: pkg -> InstalledPackageId+class Package pkg => HasUnitId pkg where+  installedUnitId :: pkg -> UnitId +{-# DEPRECATED installedPackageId "Use installedUnitId instead" #-}+-- | Compatibility wrapper for Cabal pre-1.24.+installedPackageId :: HasUnitId pkg => pkg -> UnitId+installedPackageId = installedUnitId+ -- | Class of installed packages. -- -- The primary data type which is an instance of this package is -- 'InstalledPackageInfo', but when we are doing install plans in Cabal install -- we may have other, installed package-like things which contain more metadata. -- Installed packages have exact dependencies 'installedDepends'.-class HasInstalledPackageId pkg => PackageInstalled pkg where-  installedDepends :: pkg -> [InstalledPackageId]+class (HasUnitId pkg) => PackageInstalled pkg where+  installedDepends :: pkg -> [UnitId]++-- -----------------------------------------------------------------------------+-- ABI hash++newtype AbiHash = AbiHash String+    deriving (Eq, Show, Read, Generic)+instance Binary AbiHash++instance Text AbiHash where+    disp (AbiHash abi) = Disp.text abi+    parse = fmap AbiHash (Parse.munch Char.isAlphaNum)
cabal/Cabal/Distribution/PackageDescription.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}  ----------------------------------------------------------------------------- -- |@@ -44,6 +44,7 @@         ModuleReexport(..),         emptyLibrary,         withLib,+        hasPublicLib,         hasLibs,         libModules, @@ -90,6 +91,8 @@         hcSharedOptions,          -- ** Supplementary build information+        ComponentName(..),+        defaultLibName,         HookedBuildInfo,         emptyHookedBuildInfo,         updatePackageDescription,@@ -110,43 +113,34 @@         SetupBuildInfo(..),   ) where -import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Binary+import qualified Distribution.Compat.Semigroup as Semi ((<>))+import Distribution.Compat.Semigroup as Semi (Monoid(..), Semigroup, gmempty, gmappend)+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP   ((<++))+import Distribution.Package+import Distribution.ModuleName+import Distribution.Version+import Distribution.License+import Distribution.Compiler+import Distribution.System+import Distribution.Text+import Language.Haskell.Extension+ import Data.Data                  (Data)-import Data.Foldable              (traverse_) import Data.List                  (nub, intercalate) import Data.Maybe                 (fromMaybe, maybeToList)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative        (Applicative((<*>), pure))-import Data.Monoid                (Monoid(mempty, mappend))-import Data.Foldable              (Foldable(foldMap))-import Data.Traversable           (Traversable(traverse))-#endif+import Data.Foldable as Fold      (Foldable(foldMap))+import Data.Traversable as Trav   (Traversable(traverse)) import Data.Typeable               ( Typeable )-import Control.Applicative         (Alternative(..))+import Control.Applicative as AP   (Alternative(..), Applicative(..)) import Control.Monad               (MonadPlus(mplus,mzero), ap) import GHC.Generics                (Generic) import Text.PrettyPrint as Disp-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP   ((<++)) import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) import qualified Data.Map as Map import Data.Map                    (Map) -import Distribution.Package-         ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)-         , Dependency, Package(..), PackageName, packageName )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version-         ( Version(Version), VersionRange, anyVersion, orLaterVersion-         , asVersionIntervals, LowerBound(..) )-import Distribution.License  (License(UnspecifiedLicense))-import Distribution.Compiler (CompilerFlavor)-import Distribution.System   (OS, Arch)-import Distribution.Text-         ( Text(..), display )-import Language.Haskell.Extension-         ( Language, Extension )- -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -177,6 +171,7 @@         customFieldsPD :: [(String,String)], -- ^Custom fields starting                                              -- with x-, stored in a                                              -- simple assoc-list.+         -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is         -- special! Depending on how far along processing the         -- PackageDescription we are, the contents of this field are@@ -197,7 +192,7 @@         buildType      :: Maybe BuildType,         setupBuildInfo :: Maybe SetupBuildInfo,         -- components-        library        :: Maybe Library,+        libraries      :: [Library],         executables    :: [Executable],         testSuites     :: [TestSuite],         benchmarks     :: [Benchmark],@@ -264,7 +259,7 @@                       category     = "",                       customFieldsPD = [],                       setupBuildInfo = Nothing,-                      library      = Nothing,+                      libraries    = [],                       executables  = [],                       testSuites   = [],                       benchmarks   = [],@@ -322,15 +317,13 @@  instance Binary SetupBuildInfo -instance Monoid SetupBuildInfo where-  mempty = SetupBuildInfo {-    setupDepends = mempty-  }-  mappend a b = SetupBuildInfo {-    setupDepends = combine setupDepends-  }-    where combine field = field a `mappend` field b+instance Semi.Monoid SetupBuildInfo where+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup SetupBuildInfo where+  (<>) = gmappend+ -- --------------------------------------------------------------------------- -- Module renaming @@ -352,10 +345,13 @@ instance Binary ModuleRenaming where  instance Monoid ModuleRenaming where-    ModuleRenaming b rns `mappend` ModuleRenaming b' rns'-        = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?     mempty = ModuleRenaming False []+    mappend = (Semi.<>) +instance Semigroup ModuleRenaming where+    ModuleRenaming b rns <> ModuleRenaming b' rns'+        = ModuleRenaming (b || b') (rns ++ rns') -- TODO: dedupe?+ -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. instance Text ModuleRenaming where@@ -394,6 +390,7 @@ -- The Library type  data Library = Library {+        libName :: String,         exposedModules    :: [ModuleName],         reexportedModules :: [ModuleReexport],         requiredSignatures:: [ModuleName], -- ^ What sigs need implementations?@@ -407,6 +404,7 @@  instance Monoid Library where   mempty = Library {+    libName = mempty,     exposedModules = mempty,     reexportedModules = mempty,     requiredSignatures = mempty,@@ -414,7 +412,11 @@     libExposed     = True,     libBuildInfo   = mempty   }-  mappend a b = Library {+  mappend = (Semi.<>)++instance Semigroup Library where+  a <> b = Library {+    libName = combine' libName,     exposedModules = combine exposedModules,     reexportedModules = combine reexportedModules,     requiredSignatures = combine requiredSignatures,@@ -423,26 +425,31 @@     libBuildInfo   = combine libBuildInfo   }     where combine field = field a `mappend` field b+          combine' field = case (field a, field b) of+                      ("","") -> ""+                      ("", x) -> x+                      (x, "") -> x+                      (x, y) -> error $ "Ambiguous values for library field: '"+                                  ++ x ++ "' and '" ++ y ++ "'"  emptyLibrary :: Library emptyLibrary = mempty --- |does this package have any libraries?-hasLibs :: PackageDescription -> Bool-hasLibs p = maybe False (buildable . libBuildInfo) (library p)+-- | Does this package have a PUBLIC library?+hasPublicLib :: PackageDescription -> Bool+hasPublicLib p = any f (libraries p)+    where f lib = buildable (libBuildInfo lib) &&+                  libName lib == display (packageName (package p)) --- |'Maybe' version of 'hasLibs'-maybeHasLibs :: PackageDescription -> Maybe Library-maybeHasLibs p =-   library p >>= \lib -> if buildable (libBuildInfo lib)-                           then Just lib-                           else Nothing+-- | Does this package have any libraries?+hasLibs :: PackageDescription -> Bool+hasLibs p = any (buildable . libBuildInfo) (libraries p)  -- |If the package description has a library section, call the given --  function with the library build info as argument. withLib :: PackageDescription -> (Library -> IO ()) -> IO () withLib pkg_descr f =-   traverse_ f (maybeHasLibs pkg_descr)+   sequence_ [f lib | lib <- libraries pkg_descr, buildable (libBuildInfo lib)]  -- | Get all the module names from the library (exposed and internal modules) -- which need to be compiled.  (This does not include reexports, which@@ -499,12 +506,11 @@ instance Binary Executable  instance Monoid Executable where-  mempty = Executable {-    exeName    = mempty,-    modulePath = mempty,-    buildInfo  = mempty-  }-  mappend a b = Executable{+  mempty = gmempty+  mappend = (Semi.<>)++instance Semigroup Executable where+  a <> b = Executable{     exeName    = combine' exeName,     modulePath = combine modulePath,     buildInfo  = combine buildInfo@@ -589,8 +595,10 @@         testBuildInfo = mempty,         testEnabled   = False     }+    mappend = (Semi.<>) -    mappend a b = TestSuite {+instance Semigroup TestSuite where+    a <> b = TestSuite {         testName      = combine' testName,         testInterface = combine  testInterface,         testBuildInfo = combine  testBuildInfo,@@ -605,9 +613,12 @@  instance Monoid TestSuiteInterface where     mempty  =  TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))-    mappend a (TestSuiteUnsupported _) = a-    mappend _ b                        = b+    mappend = (Semi.<>) +instance Semigroup TestSuiteInterface where+    a <> (TestSuiteUnsupported _) = a+    _ <> b                        = b+ emptyTestSuite :: TestSuite emptyTestSuite = mempty @@ -722,8 +733,10 @@         benchmarkBuildInfo = mempty,         benchmarkEnabled   = False     }+    mappend = (Semi.<>) -    mappend a b = Benchmark {+instance Semigroup Benchmark where+    a <> b = Benchmark {         benchmarkName      = combine' benchmarkName,         benchmarkInterface = combine  benchmarkInterface,         benchmarkBuildInfo = combine  benchmarkBuildInfo,@@ -738,9 +751,12 @@  instance Monoid BenchmarkInterface where     mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))-    mappend a (BenchmarkUnsupported _) = a-    mappend _ b                        = b+    mappend = (Semi.<>) +instance Semigroup BenchmarkInterface where+    a <> (BenchmarkUnsupported _) = a+    _ <> b                        = b+ emptyBenchmark :: Benchmark emptyBenchmark = mempty @@ -800,6 +816,7 @@         ldOptions         :: [String],  -- ^ options for linker         pkgconfigDepends  :: [Dependency], -- ^ pkg-config packages that are used         frameworks        :: [String], -- ^support frameworks for Mac OS X+        extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks.         cSources          :: [FilePath],         jsSources         :: [FilePath],         hsSourceDirs      :: [FilePath], -- ^ where to look for the Haskell module hierarchy@@ -832,63 +849,68 @@  instance Monoid BuildInfo where   mempty = BuildInfo {-    buildable         = True,-    buildTools        = [],-    cppOptions        = [],-    ccOptions         = [],-    ldOptions         = [],-    pkgconfigDepends  = [],-    frameworks        = [],-    cSources          = [],-    jsSources         = [],-    hsSourceDirs      = [],-    otherModules      = [],-    defaultLanguage   = Nothing,-    otherLanguages    = [],-    defaultExtensions = [],-    otherExtensions   = [],-    oldExtensions     = [],-    extraLibs         = [],-    extraGHCiLibs     = [],-    extraLibDirs      = [],-    includeDirs       = [],-    includes          = [],-    installIncludes   = [],-    options           = [],-    profOptions       = [],-    sharedOptions     = [],-    customFieldsBI    = [],-    targetBuildDepends = [],+    buildable           = True,+    buildTools          = [],+    cppOptions          = [],+    ccOptions           = [],+    ldOptions           = [],+    pkgconfigDepends    = [],+    frameworks          = [],+    extraFrameworkDirs  = [],+    cSources            = [],+    jsSources           = [],+    hsSourceDirs        = [],+    otherModules        = [],+    defaultLanguage     = Nothing,+    otherLanguages      = [],+    defaultExtensions   = [],+    otherExtensions     = [],+    oldExtensions       = [],+    extraLibs           = [],+    extraGHCiLibs       = [],+    extraLibDirs        = [],+    includeDirs         = [],+    includes            = [],+    installIncludes     = [],+    options             = [],+    profOptions         = [],+    sharedOptions       = [],+    customFieldsBI      = [],+    targetBuildDepends  = [],     targetBuildRenaming = Map.empty   }-  mappend a b = BuildInfo {-    buildable         = buildable a && buildable b,-    buildTools        = combine    buildTools,-    cppOptions        = combine    cppOptions,-    ccOptions         = combine    ccOptions,-    ldOptions         = combine    ldOptions,-    pkgconfigDepends  = combine    pkgconfigDepends,-    frameworks        = combineNub frameworks,-    cSources          = combineNub cSources,-    jsSources         = combineNub jsSources,-    hsSourceDirs      = combineNub hsSourceDirs,-    otherModules      = combineNub otherModules,-    defaultLanguage   = combineMby defaultLanguage,-    otherLanguages    = combineNub otherLanguages,-    defaultExtensions = combineNub defaultExtensions,-    otherExtensions   = combineNub otherExtensions,-    oldExtensions     = combineNub oldExtensions,-    extraLibs         = combine    extraLibs,-    extraGHCiLibs     = combine    extraGHCiLibs,-    extraLibDirs      = combineNub extraLibDirs,-    includeDirs       = combineNub includeDirs,-    includes          = combineNub includes,-    installIncludes   = combineNub installIncludes,-    options           = combine    options,-    profOptions       = combine    profOptions,-    sharedOptions     = combine    sharedOptions,-    customFieldsBI    = combine    customFieldsBI,-    targetBuildDepends = combineNub targetBuildDepends,+  mappend = (Semi.<>)++instance Semigroup BuildInfo where+  a <> b = BuildInfo {+    buildable           = buildable a && buildable b,+    buildTools          = combine    buildTools,+    cppOptions          = combine    cppOptions,+    ccOptions           = combine    ccOptions,+    ldOptions           = combine    ldOptions,+    pkgconfigDepends    = combine    pkgconfigDepends,+    frameworks          = combineNub frameworks,+    extraFrameworkDirs  = combineNub extraFrameworkDirs,+    cSources            = combineNub cSources,+    jsSources           = combineNub jsSources,+    hsSourceDirs        = combineNub hsSourceDirs,+    otherModules        = combineNub otherModules,+    defaultLanguage     = combineMby defaultLanguage,+    otherLanguages      = combineNub otherLanguages,+    defaultExtensions   = combineNub defaultExtensions,+    otherExtensions     = combineNub otherExtensions,+    oldExtensions       = combineNub oldExtensions,+    extraLibs           = combine    extraLibs,+    extraGHCiLibs       = combine    extraGHCiLibs,+    extraLibDirs        = combineNub extraLibDirs,+    includeDirs         = combineNub includeDirs,+    includes            = combineNub includes,+    installIncludes     = combineNub installIncludes,+    options             = combine    options,+    profOptions         = combine    profOptions,+    sharedOptions       = combine    sharedOptions,+    customFieldsBI      = combine    customFieldsBI,+    targetBuildDepends  = combineNub targetBuildDepends,     targetBuildRenaming = combineMap targetBuildRenaming   }     where@@ -904,7 +926,7 @@ -- all buildable executables, test suites and benchmarks.  Useful for gathering -- dependencies. allBuildInfo :: PackageDescription -> [BuildInfo]-allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]+allBuildInfo pkg_descr = [ bi | lib <- libraries pkg_descr                               , let bi = libBuildInfo lib                               , buildable bi ]                       ++ [ bi | exe <- executables pkg_descr@@ -939,10 +961,22 @@ usedExtensions bi = oldExtensions bi                  ++ defaultExtensions bi -type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])+-- Libraries live in a separate namespace, so must distinguish+data ComponentName = CLibName   String+                   | CExeName   String+                   | CTestName  String+                   | CBenchName String+                   deriving (Eq, Generic, Ord, Read, Show) +instance Binary ComponentName++defaultLibName :: PackageIdentifier -> ComponentName+defaultLibName pid = CLibName (display (pkgName pid))++type HookedBuildInfo = [(ComponentName, BuildInfo)]+ emptyHookedBuildInfo :: HookedBuildInfo-emptyHookedBuildInfo = (Nothing, [])+emptyHookedBuildInfo = []  -- |Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String]@@ -1098,28 +1132,38 @@ -- ------------------------------------------------------------  updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription-updatePackageDescription (mb_lib_bi, exe_bi) p-    = p{ executables = updateExecutables exe_bi    (executables p)-       , library     = updateLibrary     mb_lib_bi (library     p)-       }+updatePackageDescription hooked_bis p+  = p{ executables = updateMany (CExeName . exeName)         updateExecutable (executables p)+     , libraries   = updateMany (CLibName . libName)         updateLibrary    (libraries   p)+     , benchmarks  = updateMany (CBenchName . benchmarkName) updateBenchmark  (benchmarks p)+     , testSuites  = updateMany (CTestName . testName)       updateTestSuite  (testSuites p)+     }     where-      updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library-      updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})-      updateLibrary Nothing   mb_lib     = mb_lib-      updateLibrary (Just _)  Nothing    = Nothing+      updateMany :: (a -> ComponentName) -- ^ get 'ComponentName' from @a@+                 -> (BuildInfo -> a -> a) -- ^ @updateExecutable@, @updateLibrary@, etc+                 -> [a]          -- ^list of components to update+                 -> [a]          -- ^list with updated components+      updateMany name update cs' = foldr (updateOne name update) cs' hooked_bis -      updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)]-                        -> [Executable]          -- ^list of executables to update-                        -> [Executable]          -- ^list with exeNames updated-      updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'+      updateOne :: (a -> ComponentName) -- ^ get 'ComponentName' from @a@+                -> (BuildInfo -> a -> a) -- ^ @updateExecutable@, @updateLibrary@, etc+                -> (ComponentName, BuildInfo) -- ^(name, new buildinfo)+                -> [a]        -- ^list of components to update+                -> [a]        -- ^list with name component updated+      updateOne _ _ _                 []         = []+      updateOne name_sel update hooked_bi'@(name,bi) (c:cs)+        | name_sel c == name ||+          -- Special case: an empty name means "please update the BuildInfo for+          -- the public library, i.e. the one with the same name as the+          -- package."  See 'parseHookedBuildInfo'.+          name == CLibName "" && name_sel c == defaultLibName (package p)+          = update bi c : cs+        | otherwise          = c : updateOne name_sel update hooked_bi' cs -      updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)-                       -> [Executable]        -- ^list of executables to update-                       -> [Executable]        -- ^list with exeName updated-      updateExecutable _                 []         = []-      updateExecutable exe_bi'@(name,bi) (exe:exes)-        | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes-        | otherwise           = exe : updateExecutable exe_bi' exes+      updateExecutable bi exe = exe{buildInfo    = bi `mappend` buildInfo exe}+      updateLibrary    bi lib = lib{libBuildInfo = bi `mappend` libBuildInfo lib}+      updateBenchmark  bi ben = ben{benchmarkBuildInfo = bi `mappend` benchmarkBuildInfo ben}+      updateTestSuite  bi test = test{testBuildInfo = bi `mappend` testBuildInfo test}  -- --------------------------------------------------------------------------- -- The GenericPackageDescription type@@ -1128,17 +1172,17 @@     GenericPackageDescription {         packageDescription :: PackageDescription,         genPackageFlags       :: [Flag],-        condLibrary        :: Maybe (CondTree ConfVar [Dependency] Library),+        condLibraries      :: [(String, CondTree ConfVar [Dependency] Library)],         condExecutables    :: [(String, CondTree ConfVar [Dependency] Executable)],         condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)],         condBenchmarks     :: [(String, CondTree ConfVar [Dependency] Benchmark)]       }-    deriving (Show, Eq, Typeable, Data)+    deriving (Show, Eq, Typeable, Data, Generic)  instance Package GenericPackageDescription where   packageId = packageId . packageDescription ---TODO: make PackageDescription an instance of Text.+instance Binary GenericPackageDescription  -- | A flag can represent a feature to be included, or a way of linking --   a target against its dependencies, or in fact whatever you can think of.@@ -1148,8 +1192,10 @@     , flagDefault     :: Bool     , flagManual      :: Bool     }-    deriving (Show, Eq, Typeable, Data)+    deriving (Show, Eq, Typeable, Data, Generic) +instance Binary Flag+ -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String     deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)@@ -1168,15 +1214,17 @@              | Arch Arch              | Flag FlagName              | Impl CompilerFlavor VersionRange-    deriving (Eq, Show, Typeable, Data)+    deriving (Eq, Show, Typeable, Data, Generic) +instance Binary ConfVar+ -- | A boolean expression parameterized over the variable type used. data Condition c = Var c                  | Lit Bool                  | CNot (Condition c)                  | COr (Condition c) (Condition c)                  | CAnd (Condition c) (Condition c)-    deriving (Show, Eq, Typeable, Data)+    deriving (Show, Eq, Typeable, Data, Generic)  cNot :: Condition a -> Condition a cNot (Lit b)  = Lit (not b)@@ -1193,23 +1241,23 @@ instance Foldable Condition where   f `foldMap` Var c    = f c   _ `foldMap` Lit _    = mempty-  f `foldMap` CNot c   = foldMap f c+  f `foldMap` CNot c   = Fold.foldMap f c   f `foldMap` COr c d  = foldMap f c `mappend` foldMap f d   f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d  instance Traversable Condition where   f `traverse` Var c    = Var `fmap` f c   _ `traverse` Lit c    = pure $ Lit c-  f `traverse` CNot c   = CNot `fmap` traverse f c+  f `traverse` CNot c   = CNot `fmap` Trav.traverse f c   f `traverse` COr c d  = COr  `fmap` traverse f c <*> traverse f d   f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d  instance Applicative Condition where-  pure  = return+  pure  = Var   (<*>) = ap  instance Monad Condition where-  return = Var+  return = AP.pure   -- Terminating cases   (>>=) (Lit x) _ = Lit x   (>>=) (Var x) f = f x@@ -1220,8 +1268,11 @@  instance Monoid (Condition a) where   mempty = Lit False-  mappend = COr+  mappend = (Semi.<>) +instance Semigroup (Condition a) where+  (<>) = COr+ instance Alternative Condition where   empty = mempty   (<|>) = mappend@@ -1230,6 +1281,8 @@   mzero = mempty   mplus = mappend +instance Binary c => Binary (Condition c)+ data CondTree v c a = CondNode     { condTreeData        :: a     , condTreeConstraints :: c@@ -1237,4 +1290,6 @@                               , CondTree v c a                               , Maybe (CondTree v c a))]     }-    deriving (Show, Eq, Typeable, Data)+    deriving (Show, Eq, Typeable, Data, Generic)++instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
cabal/Cabal/Distribution/PackageDescription/Check.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoMonoLocalBinds #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription.Check@@ -33,50 +34,30 @@         checkPackageFileNames,   ) where -import Data.Maybe-         ( isNothing, isJust, catMaybes, maybeToList, fromMaybe )-import Data.List  (sort, group, isPrefixOf, nub, find)-import Control.Monad-         ( filterM, liftM )-import qualified System.Directory as System-         ( doesFileExist, doesDirectoryExist )-import qualified Data.Map as Map- import Distribution.PackageDescription import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription, finalizePackageDescription ) import Distribution.Compiler-         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)-         , unknownCompilerInfo, AbiTag(..) ) import Distribution.System-         ( OS(..), Arch(..), buildPlatform ) import Distribution.License-         ( License(..), knownLicenses ) import Distribution.Simple.CCompiler-         ( filenameCDialect )-import Distribution.Simple.Utils-         ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase, startsWithBOM, fromUTF8 )-+import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Version-         ( Version(..)-         , VersionRange(..), foldVersionRange'-         , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion-         , orLaterVersion, orEarlierVersion-         , unionVersionRanges, intersectVersionRanges-         , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package-         ( PackageName(PackageName), packageName, packageVersion-         , Dependency(..), pkgName )- import Distribution.Text-         ( display, disp )+import Language.Haskell.Extension++import Data.Maybe+         ( isNothing, isJust, catMaybes, mapMaybe, fromMaybe )+import Data.List  (sort, group, isPrefixOf, nub, find)+import Control.Monad+         ( filterM, liftM )+import qualified System.Directory as System+         ( doesFileExist, doesDirectoryExist )+import qualified Data.Map as Map+ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) -import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)-import Language.Haskell.Extension-         ( Language(UnknownLanguage), knownLanguages-         , Extension(..), KnownExtension(..) ) import qualified System.Directory (getDirectoryContents) import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents) import System.FilePath@@ -111,7 +92,7 @@      | PackageDistSuspicious { explanation :: String }         -- | Like PackageDistSuspicious but will only display warnings-       -- rather than causing abnormal exit.+       -- rather than causing abnormal exit when you run 'cabal check'.      | PackageDistSuspiciousWarn { explanation :: String }         -- | An issue that is OK in the author's environment but is almost@@ -193,19 +174,19 @@   , check (all ($ pkg) [ null . executables                        , null . testSuites                        , null . benchmarks-                       , isNothing . library ]) $+                       , null . libraries ]) $       PackageBuildImpossible         "No executables, libraries, tests, or benchmarks found. Nothing to do."    , check (not (null duplicateNames)) $       PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames-        ++ ". The name of every executable, test suite, and benchmark section in"+        ++ ". The name of every library, executable, test suite, and benchmark section in"         ++ " the package must be unique."   ]   --TODO: check for name clashes case insensitively: windows file systems cannot   --cope. -  ++ maybe []  (checkLibrary    pkg) (library pkg)+  ++ concatMap (checkLibrary    pkg) (libraries pkg)   ++ concatMap (checkExecutable pkg) (executables pkg)   ++ concatMap (checkTestSuite  pkg) (testSuites pkg)   ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)@@ -219,10 +200,15 @@         ++ "tool only supports up to version " ++ display cabalVersion ++ "."   ]   where+    -- The public library gets special dispensation, because it+    -- is common practice to export a library and name the executable+    -- the same as the package.  We always put the public library+    -- in the top-level directory in dist, so no conflicts either.+    libNames = filter (/= unPackageName (packageName pkg)) . map libName $ libraries pkg     exeNames = map exeName $ executables pkg     testNames = map testName $ testSuites pkg     bmNames = map benchmarkName $ benchmarks pkg-    duplicateNames = dups $ exeNames ++ testNames ++ bmNames+    duplicateNames = dups $ libNames ++ exeNames ++ testNames ++ bmNames  checkLibrary :: PackageDescription -> Library -> [PackageCheck] checkLibrary pkg lib =@@ -317,14 +303,6 @@       PackageDistInexcusable $            "The package uses a C/C++/obj-C source file for the 'main-is' field. "         ++ "To use this feature you must specify 'cabal-version: >= 1.18'."--    -- Test suites might be built as (internal) libraries named after-    -- the test suite and thus their names must not clash with the-    -- name of the package.-  , check libNameClash $-      PackageBuildImpossible $-           "The test suite " ++ testName test-        ++ " has the same name as the package."   ]   where     moduleDuplicates = dups $ testModules test@@ -337,13 +315,8 @@       TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]       _                   -> False -    libNameClash = testName test `elem` [ libName-                                        | _lib <- maybeToList (library pkg)-                                        , let PackageName libName =-                                                pkgName (package pkg) ]- checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]-checkBenchmark pkg bm =+checkBenchmark _pkg bm =   catMaybes [      case benchmarkInterface bm of@@ -369,12 +342,6 @@       PackageBuildImpossible $            "The 'main-is' field must specify a '.hs' or '.lhs' file "         ++ "(even if it is generated by a preprocessor)."--    -- See comment for similar check on test suites.-  , check libNameClash $-      PackageBuildImpossible $-           "The benchmark " ++ benchmarkName bm-        ++ " has the same name as the package."   ]   where     moduleDuplicates = dups $ benchmarkModules bm@@ -383,11 +350,6 @@       BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]       _                   -> False -    libNameClash = benchmarkName bm `elem` [ libName-                                           | _lib <- maybeToList (library pkg)-                                           , let PackageName libName =-                                                   pkgName (package pkg) ]- -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------@@ -403,6 +365,11 @@         ++ "need to convert package names to file names so using this name "         ++ "would cause problems." +  , check ((isPrefixOf "z-") . display . packageName $ pkg) $+      PackageDistInexcusable $+           "Package names with the prefix 'z-' are reserved by Cabal and "+        ++ "cannot be used."+   , check (isNothing (buildType pkg)) $       PackageBuildWarning $            "No 'build-type' specified. If you do not need a custom Setup.hs or "@@ -442,14 +409,14 @@         ++ ". Languages must be specified in either the 'default-language' "         ++ " or the 'other-languages' field." -  , check (not (null deprecatedExtensions)) $+  , check (not (null ourDeprecatedExtensions)) $       PackageDistSuspicious $            "Deprecated extensions: "-        ++ commaSep (map (quote . display . fst) deprecatedExtensions)+        ++ commaSep (map (quote . display . fst) ourDeprecatedExtensions)         ++ ". " ++ unwords              [ "Instead of '" ++ display ext             ++ "' use '" ++ display replacement ++ "'."-             | (ext, Just replacement) <- deprecatedExtensions ]+             | (ext, Just replacement) <- ourDeprecatedExtensions ]    , check (null (category pkg)) $       PackageDistSuspicious "No 'category' field."@@ -491,8 +458,8 @@     unknownExtensions = [ name | bi <- allBuildInfo pkg                                , UnknownExtension name <- allExtensions bi                                , name `notElem` map display knownLanguages ]-    deprecatedExtensions = nub $ catMaybes-      [ find ((==ext) . fst) Extension.deprecatedExtensions+    ourDeprecatedExtensions = nub $ catMaybes+      [ find ((==ext) . fst) deprecatedExtensions       | bi <- allBuildInfo pkg       , ext <- allExtensions bi ]     languagesUsedAsExtensions =@@ -624,7 +591,7 @@       PackageBuildWarning $            "'ghc-options: -prof' is not necessary and will lead to problems "         ++ "when used on a library. Use the configure flag "-        ++ "--enable-library-profiling and/or --enable-executable-profiling."+        ++ "--enable-library-profiling and/or --enable-profiling."    , checkFlags ["-o"] $       PackageBuildWarning $@@ -713,12 +680,21 @@    , checkAlternatives "ghc-options" "extra-lib-dirs"       [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]++  , checkAlternatives "ghc-options" "frameworks"+      [ (flag, fmwk) | (flag@"-framework", fmwk) <-+           zip all_ghc_options (safeTail all_ghc_options) ]++  , checkAlternatives "ghc-options" "extra-framework-dirs"+      [ (flag, dir) | (flag@"-framework-path", dir) <-+           zip all_ghc_options (safeTail all_ghc_options) ]   ]    where     all_ghc_options    = concatMap get_ghc_options (allBuildInfo pkg)-    lib_ghc_options    = maybe [] (get_ghc_options . libBuildInfo) (library pkg)+    lib_ghc_options    = concatMap (get_ghc_options . libBuildInfo) (libraries pkg)     get_ghc_options bi = hcOptions GHC bi ++ hcProfOptions GHC bi+                         ++ hcSharedOptions GHC bi      checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck     checkFlags flags = check (any (`elem` flags) all_ghc_options)@@ -939,9 +915,18 @@         ++ "different modules then list the other ones in the "         ++ "'other-languages' field." +  , checkVersion [1,23]+    (case libraries pkg of+        [lib] -> libName lib /= unPackageName (packageName pkg)+        [] -> False+        _ -> True) $+      PackageDistInexcusable $+           "To use multiple 'library' sections or a named library section "+        ++ "the package needs to specify at least 'cabal-version >= 1.23'."+     -- check use of reexported-modules sections   , checkVersion [1,21]-    (maybe False (not.null.reexportedModules) (library pkg)) $+    (any (not.null.reexportedModules) (libraries pkg)) $       PackageDistInexcusable $            "To use the 'reexported-module' field the package needs to specify "         ++ "at least 'cabal-version: >= 1.21'."@@ -955,6 +940,13 @@         ++ ". To use this new syntax, the package needs to specify at least"         ++ "'cabal-version: >= 1.21'." +    -- check use of 'extra-framework-dirs' field+  , checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $+      -- Just a warning, because this won't break on old Cabal versions.+      PackageDistSuspiciousWarn $+           "To use the 'extra-framework-dirs' field the package needs to specify"+        ++ " at least 'cabal-version: >= 1.23'."+     -- check use of default-extensions field     -- don't need to do the equivalent check for other-extensions   , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $@@ -1080,7 +1072,7 @@   , check (specVersion pkg < Version [1,23] []            && isNothing (setupBuildInfo pkg)            && buildType pkg == Just Custom) $-      PackageDistSuspicious $+      PackageDistSuspiciousWarn $            "From version 1.23 cabal supports specifiying explicit dependencies "         ++ "for Custom setup scripts. Consider using cabal-version >= 1.23 and "         ++ "adding a 'custom-setup' section with a 'setup-depends' field "@@ -1152,8 +1144,7 @@     depsUsingThinningRenamingSyntax =       [ name       | bi <- allBuildInfo pkg-      , (name, rns) <- Map.toList (targetBuildRenaming bi)-      , rns /= ModuleRenaming True [] ]+      , (name, _) <- Map.toList (targetBuildRenaming bi) ]      testedWithUsingWildcardSyntax =       [ Dependency (PackageName (display compiler)) vr@@ -1341,10 +1332,10 @@     unknownOSs    = [ os   | OS   (OtherOS os)           <- conditions ]     unknownArches = [ arch | Arch (OtherArch arch)       <- conditions ]     unknownImpls  = [ impl | Impl (OtherCompiler impl) _ <- conditions ]-    conditions = maybe [] freeVars (condLibrary pkg)-              ++ concatMap (freeVars . snd) (condExecutables pkg)-    freeVars (CondNode _ _ ifs) = concatMap compfv ifs-    compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct+    conditions = concatMap (fvs . snd) (condLibraries pkg)+              ++ concatMap (fvs . snd) (condExecutables pkg)+    fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables+    compfv (c, ct, mct) = condfv c ++ fvs ct ++ maybe [] fvs mct     condfv c = case c of       Var v      -> [v]       Lit _      -> []@@ -1408,6 +1399,7 @@     has_Wall         = "-Wall"   `elem` ghc_options     has_W            = "-W"      `elem` ghc_options     ghc_options      = hcOptions GHC bi ++ hcProfOptions GHC bi+                       ++ hcSharedOptions GHC bi      checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck     checkFlags flags = check (any (`elem` flags) ghc_options)@@ -1444,8 +1436,8 @@      allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]     allConditionalBuildInfo =-        concatMap (collectCondTreePaths libBuildInfo)-                  (maybeToList (condLibrary pkg))+        concatMap (collectCondTreePaths libBuildInfo . snd)+                  (condLibraries pkg)       ++ concatMap (collectCondTreePaths buildInfo . snd)                   (condExecutables pkg)@@ -1538,7 +1530,8 @@                                     pdfile ++ " starts with an Unicode byte order mark (BOM). This may cause problems with older cabal versions."  -- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.+-- @.cabal@ files.  Like 'Distribution.Simple.Utils.findPackageDesc',+-- but generalized over monads. findPackageDesc :: Monad m => CheckPackageContentOps m                  -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal findPackageDesc ops@@ -1610,6 +1603,8 @@              | bi <- allBuildInfo pkg              , (dir, kind) <-                   [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]+               ++ [ (dir, "extra-framework-dirs")+                  | dir <- extraFrameworkDirs  bi ]                ++ [ (dir, "include-dirs")   | dir <- includeDirs  bi ]                ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]              , isRelative dir ]@@ -1658,8 +1653,8 @@ -- checkPackageFileNames :: [FilePath] -> [PackageCheck] checkPackageFileNames files =-     (take 1 . catMaybes . map checkWindowsPath $ files)-  ++ (take 1 . catMaybes . map checkTarPath     $ files)+     (take 1 . mapMaybe checkWindowsPath $ files)+  ++ (take 1 . mapMaybe checkTarPath     $ files)       -- If we get any of these checks triggering then we're likely to get       -- many, and that's probably not helpful, so return at most one.
cabal/Cabal/Distribution/PackageDescription/Configuration.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- -fno-warn-deprecations for use of Map.foldWithKey {-# OPTIONS_GHC -fno-warn-deprecations #-} -----------------------------------------------------------------------------@@ -23,46 +22,34 @@     -- Utils     parseCondition,     freeVars,+    extractCondition,+    addBuildableCondition,     mapCondTree,     mapTreeData,     mapTreeConds,     mapTreeConstrs,+    transformAllBuildInfos,+    transformAllBuildDepends,   ) where  import Distribution.Package-         ( PackageName, Dependency(..) ) import Distribution.PackageDescription-         ( GenericPackageDescription(..), PackageDescription(..)-         , Library(..), Executable(..), BuildInfo(..)-         , Flag(..), FlagName(..), FlagAssignment-         , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)-         , TestSuite(..) ) import Distribution.PackageDescription.Utils-         ( cabalBug, userBug ) import Distribution.Version-         ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler-         ( CompilerId(CompilerId) ) import Distribution.System-         ( Platform(..), OS, Arch ) import Distribution.Simple.Utils-         ( currentDir, lowercase )-import Distribution.Simple.Compiler-         ( CompilerInfo(..) )- import Distribution.Text-         ( Text(parse) ) import Distribution.Compat.ReadP as ReadP hiding ( char )-import Control.Arrow (first) import qualified Distribution.Compat.ReadP as ReadP ( char )+import Distribution.Compat.Semigroup as Semi +import Control.Arrow (first) import Data.Char ( isAlphaNum )-import Data.Maybe ( catMaybes, maybeToList )+import Data.Maybe ( mapMaybe, maybeToList ) import Data.Map ( Map, fromListWith, toList ) import qualified Data.Map as Map-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif+import Data.Tree ( Tree(Node) )  ------------------------------------------------------------------------------ @@ -185,14 +172,14 @@ --   clarity. data DepTestRslt d = DepOk | MissingDeps d -instance Monoid d => Monoid (DepTestRslt d) where+instance Semigroup d => Monoid (DepTestRslt d) where     mempty = DepOk-    mappend DepOk x = x-    mappend x DepOk = x-    mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')-+    mappend = (Semi.<>) -data BT a = BTN a | BTB (BT a) (BT a)  -- very simple binary tree+instance Semigroup d => Semigroup (DepTestRslt d) where+    DepOk <> x     = x+    x     <> DepOk = x+    (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')   -- | Try to find a flag assignment that satisfies the constraints of all trees.@@ -201,8 +188,9 @@ -- resulting data, the associated dependencies, and the chosen flag -- assignments. ----- In case of failure, the _smallest_ number of of missing dependencies is--- returned. [TODO: Could also be specified with a function argument.]+-- In case of failure, the union of the dependencies that led to backtracking+-- on all branches is returned.+-- [TODO: Could also be specified with a function argument.] -- -- TODO: The current algorithm is rather naive.  A better approach would be to: --@@ -228,65 +216,132 @@        -- ^ Either the missing dependencies (error case), or a pair of        -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom os arch impl constrs trees checkDeps =-    case try dom [] of-      Right r -> Right r-      Left dbt -> Left $ findShortest dbt+    either (Left . fromDepMapUnion) Right $ explore (build [] dom)   where     extraConstrs = toDepMap constrs      -- simplify trees by (partially) evaluating all conditions and converting     -- dependencies to dependency maps.+    simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]     simplifiedTrees = map ( mapTreeConstrs toDepMap  -- convert to maps+                          . addBuildableCondition pdTaggedBuildInfo                           . mapTreeConds (fst . simplifyWithSysParams os arch impl))                           trees -    -- @try@ recursively tries all possible flag assignments in the domain and-    -- either succeeds or returns a binary tree with the missing dependencies-    -- encountered in each run.  Since the tree is constructed lazily, we-    -- avoid some computation overhead in the successful case.-    try [] flags =+    -- @explore@ searches a tree of assignments, backtracking whenever a flag+    -- introduces a dependency that cannot be satisfied.  If there is no+    -- solution, @explore@ returns the union of all dependencies that caused+    -- it to backtrack.  Since the tree is constructed lazily, we avoid some+    -- computation overhead in the successful case.+    explore :: Tree FlagAssignment+            -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)+    explore (Node flags ts) =         let targetSet = TargetSet $ flip map simplifiedTrees $                 -- apply additional constraints to all dependencies                 first (`constrainBy` extraConstrs) .                 simplifyCondTree (env flags)             deps = overallDependencies targetSet         in case checkDeps (fromDepMap deps) of-             DepOk           -> Right (targetSet, flags)-             MissingDeps mds -> Left (BTN mds)+             DepOk | null ts   -> Right (targetSet, flags)+                   | otherwise -> tryAll $ map explore ts+             MissingDeps mds   -> Left (toDepMapUnion mds) -    try ((n, vals):rest) flags =-        tryAll $ map (\v -> try rest ((n, v):flags)) vals+    -- Builds a tree of all possible flag assignments.  Internal nodes+    -- have only partial assignments.+    build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment+    build assigned [] = Node assigned []+    build assigned ((fn, vals) : unassigned) =+        Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals +    tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a     tryAll = foldr mp mz      -- special version of `mplus' for our local purposes-    mp (Left xs)   (Left ys)   = (Left (BTB xs ys))-    mp (Left _)    m@(Right _) = m+    mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a     mp m@(Right _) _           = m+    mp _           m@(Right _) = m+    mp (Left xs)   (Left ys)   =+        let union = Map.foldrWithKey (Map.insertWith' combine)+                    (unDepMapUnion xs) (unDepMapUnion ys)+            combine x y = simplifyVersionRange $ unionVersionRanges x y+        in union `seq` Left (DepMapUnion union)      -- `mzero'-    mz = Left (BTN [])+    mz :: Either DepMapUnion a+    mz = Left (DepMapUnion Map.empty) +    env :: FlagAssignment -> FlagName -> Either FlagName Bool     env flags flag = (maybe (Left flag) Right . lookup flag) flags -    -- for the error case we inspect our lazy tree of missing dependencies and-    -- pick the shortest list of missing dependencies-    findShortest (BTN x) = x-    findShortest (BTB lt rt) =-        let l = findShortest lt-            r = findShortest rt-        in case (l,r) of-             ([], xs) -> xs  -- [] is too short-             (xs, []) -> xs-             ([x], _) -> [x] -- single elem is optimum-             (_, [x]) -> [x]-             (xs, ys) -> if lazyLengthCmp xs ys-                         then xs else ys-    -- lazy variant of @\xs ys -> length xs <= length ys@-    lazyLengthCmp [] _ = True-    lazyLengthCmp _ [] = False-    lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys+    pdTaggedBuildInfo :: PDTagged -> BuildInfo+    pdTaggedBuildInfo (Lib _ l) = libBuildInfo l+    pdTaggedBuildInfo (Exe _ e) = buildInfo e+    pdTaggedBuildInfo (Test _ t) = testBuildInfo t+    pdTaggedBuildInfo (Bench _ b) = benchmarkBuildInfo b+    pdTaggedBuildInfo PDNull = mempty +-- | Transforms a 'CondTree' by putting the input under the "then" branch of a+-- conditional that is True when Buildable is True. If 'addBuildableCondition'+-- can determine that Buildable is always True, it returns the input unchanged.+-- If Buildable is always False, it returns the empty 'CondTree'.+addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo)+                      -> CondTree v c a+                      -> CondTree v c a+addBuildableCondition getInfo t =+  case extractCondition (buildable . getInfo) t of+    Lit True  -> t+    Lit False -> CondNode mempty mempty []+    c         -> CondNode mempty mempty [(c, t, Nothing)]++-- | Extract buildable condition from a cond tree.+--+-- Background: If the conditions in a cond tree lead to Buildable being set to False,+-- then none of the dependencies for this cond tree should actually be taken into+-- account. On the other hand, some of the flags may only be decided in the solver,+-- so we cannot necessarily make the decision whether a component is Buildable or not+-- prior to solving.+--+-- What we are doing here is to partially evaluate a condition tree in order to extract+-- the condition under which Buildable is True. The predicate determines whether data+-- under a 'CondTree' is buildable.+extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v+extractCondition p = go+  where+    go (CondNode x _ cs) | not (p x) = Lit False+                         | otherwise = goList cs++    goList []               = Lit True+    goList ((c, t, e) : cs) =+      let+        ct = go t+        ce = maybe (Lit True) go e+      in+        ((c `cand` ct) `cor` (CNot c `cand` ce)) `cand` goList cs++    cand (Lit False) _           = Lit False+    cand _           (Lit False) = Lit False+    cand (Lit True)  x           = x+    cand x           (Lit True)  = x+    cand x           y           = CAnd x y++    cor  (Lit True)  _           = Lit True+    cor  _           (Lit True)  = Lit True+    cor  (Lit False) x           = x+    cor  x           (Lit False) = x+    cor  c           (CNot d)+      | c == d                   = Lit True+    cor  x           y           = COr x y++-- | A map of dependencies that combines version ranges using 'unionVersionRanges'.+newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName VersionRange }++toDepMapUnion :: [Dependency] -> DepMapUnion+toDepMapUnion ds =+  DepMapUnion $ fromListWith unionVersionRanges [ (p,vr) | Dependency p vr <- ds ]++fromDepMapUnion :: DepMapUnion -> [Dependency]+fromDepMapUnion m = [ Dependency p vr | (p,vr) <- toList (unDepMapUnion m) ]+ -- | A map of dependencies.  Newtyped since the default monoid instance is not --   appropriate.  The monoid instance uses 'intersectVersionRanges'. newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }@@ -294,7 +349,10 @@  instance Monoid DependencyMap where     mempty = DependencyMap Map.empty-    (DependencyMap a) `mappend` (DependencyMap b) =+    mappend = (Semi.<>)++instance Semigroup DependencyMap where+    (DependencyMap a) <> (DependencyMap b) =         DependencyMap (Map.unionWith intersectVersionRanges a b)  toDepMap :: [Dependency] -> DependencyMap@@ -304,18 +362,20 @@ fromDepMap :: DependencyMap -> [Dependency] fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] +-- | Flattens a CondTree using a partial flag assignment.  When a condition+-- cannot be evaluated, both branches are ignored. simplifyCondTree :: (Monoid a, Monoid d) =>                     (v -> Either v Bool)                  -> CondTree v d a                  -> (d, a) simplifyCondTree env (CondNode a d ifs) =-    mconcat $ (d, a) : catMaybes (map simplifyIf ifs)+    mconcat $ (d, a) : mapMaybe simplifyIf ifs   where     simplifyIf (cnd, t, me) =         case simplifyCondition cnd env of           (Lit True, _) -> Just $ simplifyCondTree env t           (Lit False, _) -> fmap (simplifyCondTree env) me-          _ -> error $ "Environment not defined for all free vars"+          _ -> Nothing  -- | Flatten a CondTree.  This will resolve the CondTree by taking all --  possible paths into account.  Note that since branches represent exclusive@@ -350,11 +410,11 @@   where     (depss, _) = unzip $ filter (removeDisabledSections . snd) targets     removeDisabledSections :: PDTagged -> Bool-    removeDisabledSections (Lib _) = True-    removeDisabledSections (Exe _ _) = True-    removeDisabledSections (Test _ t) = testEnabled t-    removeDisabledSections (Bench _ b) = benchmarkEnabled b-    removeDisabledSections PDNull = True+    removeDisabledSections (Lib _ l)     = buildable (libBuildInfo l)+    removeDisabledSections (Exe _ e)   = buildable (buildInfo e)+    removeDisabledSections (Test _ t)  = testEnabled t && buildable (testBuildInfo t)+    removeDisabledSections (Bench _ b) = benchmarkEnabled b && buildable (benchmarkBuildInfo b)+    removeDisabledSections PDNull      = True  -- Apply extra constraints to a dependency map. -- Combines dependencies where the result will only contain keys from the left@@ -375,50 +435,53 @@ -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. flattenTaggedTargets :: TargetSet PDTagged ->-        (Maybe Library, [(String, Executable)], [(String, TestSuite)]+        ([(String, Library)], [(String, Executable)], [(String, TestSuite)]         , [(String, Benchmark)])-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets+flattenTaggedTargets (TargetSet targets) = foldr untag ([], [], [], []) targets   where-    untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected"-    untag (deps, Lib l) (Nothing, exes, tests, bms) =-        (Just l', exes, tests, bms)+    untag (deps, Lib n l) (libs, exes, tests, bms)+        | any ((== n) . fst) libs =+          userBug $ "There exist several libs with the same name: '" ++ n ++ "'"+        -- NB: libraries live in a different namespace than everything else+        -- TODO: no, (new-style) TESTS live in same namespace!!+        | otherwise = ((n, l'):libs, exes, tests, bms)       where         l' = l {                 libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }             }-    untag (deps, Exe n e) (mlib, exes, tests, bms)+    untag (deps, Exe n e) (libs, exes, tests, bms)         | any ((== n) . fst) exes =           userBug $ "There exist several exes with the same name: '" ++ n ++ "'"         | any ((== n) . fst) tests =           userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"         | any ((== n) . fst) bms =           userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"-        | otherwise = (mlib, (n, e'):exes, tests, bms)+        | otherwise = (libs, (n, e'):exes, tests, bms)       where         e' = e {                 buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }             }-    untag (deps, Test n t) (mlib, exes, tests, bms)+    untag (deps, Test n t) (libs, exes, tests, bms)         | any ((== n) . fst) tests =           userBug $ "There exist several tests with the same name: '" ++ n ++ "'"         | any ((== n) . fst) exes =           userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"         | any ((== n) . fst) bms =           userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"-        | otherwise = (mlib, exes, (n, t'):tests, bms)+        | otherwise = (libs, exes, (n, t'):tests, bms)       where         t' = t {             testBuildInfo = (testBuildInfo t)                 { targetBuildDepends = fromDepMap deps }             }-    untag (deps, Bench n b) (mlib, exes, tests, bms)+    untag (deps, Bench n b) (libs, exes, tests, bms)         | any ((== n) . fst) bms =           userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"         | any ((== n) . fst) exes =           userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"         | any ((== n) . fst) tests =           userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"-        | otherwise = (mlib, exes, tests, (n, b'):bms)+        | otherwise = (libs, exes, tests, (n, b'):bms)       where         b' = b {             benchmarkBuildInfo = (benchmarkBuildInfo b)@@ -431,7 +494,7 @@ -- Convert GenericPackageDescription to PackageDescription -- -data PDTagged = Lib Library+data PDTagged = Lib String Library               | Exe String Executable               | Test String TestSuite               | Bench String Benchmark@@ -440,14 +503,17 @@  instance Monoid PDTagged where     mempty = PDNull-    PDNull `mappend` x = x-    x `mappend` PDNull = x-    Lib l `mappend` Lib l' = Lib (l `mappend` l')-    Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')-    Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')-    Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')-    _ `mappend` _ = cabalBug "Cannot combine incompatible tags"+    mappend = (Semi.<>) +instance Semigroup PDTagged where+    PDNull    <> x      = x+    x         <> PDNull = x+    Lib n l   <> Lib   n' l' | n == n' = Lib n (l <> l')+    Exe n e   <> Exe   n' e' | n == n' = Exe n (e <> e')+    Test n t  <> Test  n' t' | n == n' = Test n (t <> t')+    Bench n b <> Bench n' b' | n == n' = Bench n (b <> b')+    _         <> _  = cabalBug "Cannot combine incompatible tags"+ -- | Create a package description with all configurations resolved. -- -- This function takes a `GenericPackageDescription` and several environment@@ -465,9 +531,10 @@ -- -- This function will fail if it cannot find a flag assignment that leads to -- satisfiable dependencies.  (It will not try alternative assignments for--- explicitly specified flags.)  In case of failure it will return a /minimum/--- number of dependencies that could not be satisfied.  On success, it will--- return the package description and the full flag assignment chosen.+-- explicitly specified flags.)  In case of failure it will return the missing+-- dependencies that it encountered when trying different flag assignments.+-- On success, it will return the package description and the full flag+-- assignment chosen. -- finalizePackageDescription ::      FlagAssignment  -- ^ Explicitly specified flag assignments@@ -484,25 +551,21 @@              -- description along with the flag assignments chosen. finalizePackageDescription userflags satisfyDep         (Platform arch os) impl constraints-        (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =+        (GenericPackageDescription pkg flags libs0 exes0 tests0 bms0) =     case resolveFlags of-      Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->-        Right ( pkg { library = mlib+      Right ((libs', exes', tests', bms'), targetSet, flagVals) ->+        Right ( pkg { libraries = libs'                     , executables = exes'                     , testSuites = tests'                     , benchmarks = bms'                     , buildDepends = fromDepMap (overallDependencies targetSet)-                      --TODO: we need to find a way to avoid pulling in deps-                      -- for non-buildable components. However cannot simply-                      -- filter at this stage, since if the package were not-                      -- available we would have failed already.                     }               , flagVals )        Left missing -> Left missing   where     -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data-    condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )+    condTrees =    map (\(name,tree) -> mapTreeData (Lib name) tree) libs0                 ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0                 ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0                 ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0@@ -510,8 +573,8 @@     resolveFlags =         case resolveWithFlags flagChoices os arch impl constraints condTrees check of           Right (targetSet, fs) ->-              let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in-              Right ( (fmap libFillInDefaults mlib,+              let (libs, exes, tests, bms) = flattenTaggedTargets targetSet in+              Right ( (map (\(n,l) -> (libFillInDefaults l) { libName = n }) libs,                        map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,                        map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,                        map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),@@ -554,21 +617,21 @@ -- default path will be missing from the package description returned by this -- function. flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) =-    pkg { library = mlib+flattenPackageDescription (GenericPackageDescription pkg _ libs0 exes0 tests0 bms0) =+    pkg { libraries = reverse libs         , executables = reverse exes         , testSuites = reverse tests         , benchmarks = reverse bms-        , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps+        , buildDepends = reverse ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps         }   where-    (mlib, ldeps) = case mlib0 of-        Just lib -> let (l,ds) = ignoreConditions lib in-                    (Just (libFillInDefaults l), ds)-        Nothing -> (Nothing, [])+    (libs, ldeps) = foldr flattenLib ([],[]) libs0     (exes, edeps) = foldr flattenExe ([],[]) exes0     (tests, tdeps) = foldr flattenTst ([],[]) tests0     (bms, bdeps) = foldr flattenBm ([],[]) bms0+    flattenLib (n, t) (es, ds) =+        let (e, ds') = ignoreConditions t in+        ( (libFillInDefaults $ e { libName = n }) : es, ds' ++ ds )     flattenExe (n, t) (es, ds) =         let (e, ds') = ignoreConditions t in         ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )@@ -607,3 +670,82 @@     if null (hsSourceDirs bi)     then bi { hsSourceDirs = [currentDir] }     else bi++-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@+-- to all nested 'BuildInfo'/'SetupBuildInfo' values.+transformAllBuildInfos :: (BuildInfo -> BuildInfo)+                       -> (SetupBuildInfo -> SetupBuildInfo)+                       -> GenericPackageDescription+                       -> GenericPackageDescription+transformAllBuildInfos onBuildInfo onSetupBuildInfo gpd = gpd'+  where+    onLibrary    lib  = lib { libBuildInfo  = onBuildInfo $ libBuildInfo  lib }+    onExecutable exe  = exe { buildInfo     = onBuildInfo $ buildInfo     exe }+    onTestSuite  tst  = tst { testBuildInfo = onBuildInfo $ testBuildInfo tst }+    onBenchmark  bmk  = bmk { benchmarkBuildInfo =+                                 onBuildInfo $ benchmarkBuildInfo bmk }++    pd = packageDescription gpd+    pd'  = pd {+      libraries      = map  onLibrary        (libraries pd),+      executables    = map  onExecutable     (executables pd),+      testSuites     = map  onTestSuite      (testSuites pd),+      benchmarks     = map  onBenchmark      (benchmarks pd),+      setupBuildInfo = fmap onSetupBuildInfo (setupBuildInfo pd)+      }++    gpd' = transformAllCondTrees onLibrary onExecutable+           onTestSuite onBenchmark id+           $ gpd { packageDescription = pd' }++-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested+-- @build-depends@ fields.+transformAllBuildDepends :: (Dependency -> Dependency)+                         -> GenericPackageDescription+                         -> GenericPackageDescription+transformAllBuildDepends f gpd = gpd'+  where+    onBI  bi  = bi  { targetBuildDepends = map f $ targetBuildDepends bi }+    onSBI stp = stp { setupDepends       = map f $ setupDepends stp      }+    onPD  pd  = pd  { buildDepends       = map f $ buildDepends pd       }++    pd'   = onPD $ packageDescription gpd+    gpd'  = transformAllCondTrees id id id id (map f)+            . transformAllBuildInfos onBI onSBI+            $ gpd { packageDescription = pd' }++-- | Walk all 'CondTree's inside a 'GenericPackageDescription' and apply+-- appropriate transformations to all nodes. Helper function used by+-- 'transformAllBuildDepends' and 'transformAllBuildInfos'.+transformAllCondTrees :: (Library -> Library)+                      -> (Executable -> Executable)+                      -> (TestSuite -> TestSuite)+                      -> (Benchmark -> Benchmark)+                      -> ([Dependency] -> [Dependency])+                      -> GenericPackageDescription -> GenericPackageDescription+transformAllCondTrees onLibrary onExecutable+  onTestSuite onBenchmark onDepends gpd = gpd'+  where+    gpd'    = gpd {+      condLibraries      = condLibs',+      condExecutables    = condExes',+      condTestSuites     = condTests',+      condBenchmarks     = condBenchs'+      }++    condLibs   = condLibraries      gpd+    condExes   = condExecutables    gpd+    condTests  = condTestSuites     gpd+    condBenchs = condBenchmarks     gpd++    condLibs'   = map  (mapSnd $ onCondTree onLibrary)    condLibs+    condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes+    condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests+    condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs++    mapSnd :: (a -> b) -> (c,a) -> (c,b)+    mapSnd = fmap++    onCondTree :: (a -> b) -> CondTree v [Dependency] a+               -> CondTree v [Dependency] b+    onCondTree g = mapCondTree g onDepends id
cabal/Cabal/Distribution/PackageDescription/Parse.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- |@@ -41,8 +42,20 @@         flagFieldDescrs   ) where +import Distribution.ParseUtils hiding (parseFields)+import Distribution.PackageDescription+import Distribution.PackageDescription.Utils+import Distribution.Package+import Distribution.ModuleName+import Distribution.Version+import Distribution.Verbosity+import Distribution.Compiler+import Distribution.PackageDescription.Configuration+import Distribution.Simple.Utils+import Distribution.Text+import Distribution.Compat.ReadP hiding (get)+ import Data.Char     (isSpace)-import Data.Foldable (traverse_) import Data.Maybe    (listToMaybe, isJust) import Data.List     (nub, unfoldr, partition, (\\)) import Control.Monad (liftM, foldM, when, unless, ap)@@ -53,36 +66,10 @@ import Control.Arrow    (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.Typeable-import Data.Data-import qualified Data.Map as Map -import Distribution.Text-         ( Text(disp, parse), display, simpleParse )-import Distribution.Compat.ReadP-         ((+++), option)-import qualified Distribution.Compat.ReadP as Parse import Text.PrettyPrint -import Distribution.ParseUtils hiding (parseFields)-import Distribution.PackageDescription-import Distribution.PackageDescription.Utils-         ( cabalBug, userBug )-import Distribution.Package-         ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version-        ( Version(Version), orLaterVersion-        , LowerBound(..), asVersionIntervals )-import Distribution.Verbosity (Verbosity)-import Distribution.Compiler  (CompilerFlavor(..))-import Distribution.PackageDescription.Configuration (parseCondition, freeVars)-import Distribution.Simple.Utils-         ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion-         , withFileContents, withUTF8FileContents-         , writeFileAtomic, writeUTF8File ) - -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -402,8 +389,7 @@            buildTools         (\xs  binfo -> binfo{buildTools=xs})  , commaListFieldWithSep vcat "build-depends"            disp                   parse-           buildDependsWithRenaming-           setBuildDependsWithRenaming+           targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs})  , spaceListField "cpp-options"            showToken          parseTokenQ'            cppOptions          (\val binfo -> binfo{cppOptions=val})@@ -419,6 +405,9 @@  , listField "frameworks"            showToken          parseTokenQ            frameworks         (\val binfo -> binfo{frameworks=val})+ , listField "extra-framework-dirs"+           showToken          parseFilePathQ+           extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val})  , listFieldWithSep vcat "c-sources"            showFilePath       parseFilePathQ            cSources           (\paths binfo -> binfo{cSources=paths})@@ -597,7 +586,8 @@ -- prop_isMapM fs = mapSimpleFields return fs == return fs  --- names of fields that represents dependencies, thus consrca+-- names of fields that represents dependencies+-- TODO: maybe build-tools should go here too? constraintFieldNames :: [String] constraintFieldNames = ["build-depends"] @@ -605,9 +595,9 @@ -- they add and define an accessor that specifies what the dependencies -- are.  This way we would completely reuse the parsing knowledge from the -- field descriptor.-parseConstraint :: Field -> ParseResult [DependencyWithRenaming]+parseConstraint :: Field -> ParseResult [Dependency] parseConstraint (F l n v)-    | n == "build-depends" = runP l n (parseCommaList parse) v+    | n `elem` constraintFieldNames = runP l n (parseCommaList parse) v parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"  {-@@ -640,12 +630,14 @@ #else instance (Monad m, Functor m) => Applicative (StT s m) where #endif-    pure = return+    pure a = StT (\s -> return (a,s))     (<*>) = ap   instance Monad m => Monad (StT s m) where+#if __GLASGOW_HASKELL__ < 710     return a = StT (\s -> return (a,s))+#endif     StT f >>= g = StT $ \s -> do                         (a,s') <- f s                         runStT (g a) s'@@ -749,14 +741,14 @@            -- 'getBody' assumes that the remaining fields only consist of           -- flags, lib and exe sections.-        (repos, flags, mcsetup, mlib, exes, tests, bms) <- getBody+        (repos, flags, mcsetup, libs, exes, tests, bms) <- getBody pkg         warnIfRest  -- warn if getBody did not parse up to the last field.           -- warn about using old/new syntax with wrong cabal-version:         maybeWarnCabalVersion (not $ oldSyntax fields0) pkg-        checkForUndefinedFlags flags mlib exes tests+        checkForUndefinedFlags flags libs exes tests         return $ GenericPackageDescription                    pkg { sourceRepos = repos, setupBuildInfo = mcsetup }-                   flags mlib exes tests bms+                   flags libs exes tests bms    where     oldSyntax = all isSimpleField@@ -856,17 +848,18 @@         _ -> return (reverse acc)      ---    -- body ::= { repo | flag | library | executable | test }+   -- at most one lib+    -- body ::= { repo | flag | library | executable | test }+     --     -- The body consists of an optional sequence of declarations of flags and-    -- an arbitrary number of executables and at most one library.-    getBody :: PM ([SourceRepo], [Flag]+    -- an arbitrary number of libraries/executables/tests.+    getBody :: PackageDescription+            -> PM ([SourceRepo], [Flag]                   ,Maybe SetupBuildInfo-                  ,Maybe (CondTree ConfVar [Dependency] Library)+                  ,[(String, CondTree ConfVar [Dependency] Library)]                   ,[(String, CondTree ConfVar [Dependency] Executable)]                   ,[(String, CondTree ConfVar [Dependency] TestSuite)]                   ,[(String, CondTree ConfVar [Dependency] Benchmark)])-    getBody = peekField >>= \mf -> case mf of+    getBody pkg = peekField >>= \mf -> case mf of       Just (Section line_no sec_type sec_label sec_fields)         | sec_type == "executable" -> do             when (null sec_label) $ lift $ syntaxError line_no@@ -874,7 +867,7 @@             exename <- lift $ runP line_no "executable" parseTokenQ sec_label             flds <- collectFields parseExeFields sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg             return (repos, flags, csetup, lib, (exename, flds): exes, tests, bms)          | sec_type == "test-suite" -> do@@ -904,7 +897,6 @@                         -- Does the current node specify a test type?                         hasTestType = testInterface ts'                             /= testInterface emptyTestSuite-                        components = condTreeComponents ct                     -- If the current level of the tree specifies a type,                     -- then we are done. If not, then one of the conditional                     -- branches below the current node must specify a type.@@ -912,11 +904,11 @@                     -- only one need one to specify a type because the                     -- configure step uses 'mappend' to join together the                     -- results of flag resolution.-                    in hasTestType || any checkComponent components+                    in hasTestType || any checkComponent (condTreeComponents ct)             if checkTestType emptyTestSuite flds                 then do                     skipField-                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg                     return (repos, flags, csetup, lib, exes,                             (testname, flds) : tests, bms)                 else lift $ syntaxError line_no $@@ -953,7 +945,6 @@                         -- Does the current node specify a benchmark type?                         hasBenchmarkType = benchmarkInterface ts'                             /= benchmarkInterface emptyBenchmark-                        components = condTreeComponents ct                     -- If the current level of the tree specifies a type,                     -- then we are done. If not, then one of the conditional                     -- branches below the current node must specify a type.@@ -961,11 +952,11 @@                     -- only one need one to specify a type because the                     -- configure step uses 'mappend' to join together the                     -- results of flag resolution.-                    in hasBenchmarkType || any checkComponent components+                    in hasBenchmarkType || any checkComponent (condTreeComponents ct)             if checkBenchmarkType emptyBenchmark flds                 then do                     skipField-                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody+                    (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg                     return (repos, flags, csetup, lib, exes,                             tests, (benchname, flds) : bms)                 else lift $ syntaxError line_no $@@ -976,14 +967,15 @@                       ++ intercalate ", " (map display knownBenchmarkTypes)          | sec_type == "library" -> do-            unless (null sec_label) $ lift $-              syntaxError line_no "'library' expects no argument"+            libname <- if null sec_label+                        then return (unPackageName (packageName pkg))+                        -- TODO: relax this parsing so that scoping is handled+                        -- correctly+                        else lift $ runP line_no "library" parseTokenQ sec_label             flds <- collectFields parseLibFields sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody-            when (isJust lib) $ lift $ syntaxError line_no-              "There can only be one library section in a package description."-            return (repos, flags, csetup, Just flds, exes, tests, bms)+            (repos, flags, csetup, libs, exes, tests, bms) <- getBody pkg+            return (repos, flags, csetup, (libname, flds) : libs, exes, tests, bms)          | sec_type == "flag" -> do             when (null sec_label) $ lift $@@ -994,7 +986,7 @@                     (MkFlag (FlagName (lowercase sec_label)) "" True False)                     sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg             return (repos, flag:flags, csetup, lib, exes, tests, bms)          | sec_type == "source-repository" -> do@@ -1019,7 +1011,7 @@                     }                     sec_fields             skipField-            (repos, flags, csetup, lib, exes, tests, bms) <- getBody+            (repos, flags, csetup, lib, exes, tests, bms) <- getBody pkg             return (repo:repos, flags, csetup, lib, exes, tests, bms)          | sec_type == "custom-setup" -> do@@ -1031,7 +1023,7 @@                              mempty                              sec_fields             skipField-            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody+            (repos, flags, csetup0, lib, exes, tests, bms) <- getBody pkg             when (isJust csetup0) $ lift $ syntaxError line_no               "There can only be one 'custom-setup' section in a package description."             return (repos, flags, Just flds, lib, exes, tests, bms)@@ -1039,18 +1031,18 @@         | otherwise -> do             lift $ warning $ "Ignoring unknown section type: " ++ sec_type             skipField-            getBody+            getBody pkg       Just f@(F {}) -> do             _ <- lift $ syntaxError (lineNo f) $               "Plain fields are not allowed in between stanzas: " ++ show f             skipField-            getBody+            getBody pkg       Just f@(IfBlock {}) -> do             _ <- lift $ syntaxError (lineNo f) $               "If-blocks are not allowed in between stanzas: " ++ show f             skipField-            getBody-      Nothing -> return ([], [], Nothing, Nothing, [], [], [])+            getBody pkg+      Nothing -> return ([], [], Nothing, [], [], [], [])      -- Extracts all fields in a block and returns a 'CondTree'.     --@@ -1064,18 +1056,30 @@             condFlds = [ f | f@IfBlock{} <- allflds ]             sections = [ s | s@Section{} <- allflds ] -        -- Put these through the normal parsing pass too, so that we-        -- collect the ModRenamings-        let depFlds = filter isConstraint simplFlds-                 mapM_             (\(Section l n _ _) -> lift . warning $                 "Unexpected section '" ++ n ++ "' on line " ++ show l)             sections          a <- parser simplFlds-        deps <- liftM concat . mapM (lift . fmap (map dependency) .  parseConstraint) $ depFlds +        -- Dependencies must be treated specially: when we+        -- parse into a CondTree, not only do we parse them into+        -- the targetBuildDepends/etc field inside the+        -- PackageDescription, but we also have to put the+        -- combined dependencies into CondTree.+        --+        -- This information is, in principle, redundant, but+        -- putting it here makes it easier for the constraint+        -- solver to pick a flag assignment which supports+        -- all of the dependencies (because it only has+        -- to check the CondTree, rather than grovel everywhere+        -- inside the conditional bits).+        deps <- liftM concat+              . mapM (lift . parseConstraint)+              . filter isConstraint+              $ simplFlds+         ifs <- mapM processIfs condFlds          return (CondNode a deps ifs)@@ -1115,13 +1119,13 @@      checkForUndefinedFlags ::         [Flag] ->-        Maybe (CondTree ConfVar [Dependency] Library) ->+        [(String, CondTree ConfVar [Dependency] Library)] ->         [(String, CondTree ConfVar [Dependency] Executable)] ->         [(String, CondTree ConfVar [Dependency] TestSuite)] ->         PM ()-    checkForUndefinedFlags flags mlib exes tests = do+    checkForUndefinedFlags flags libs exes tests = do         let definedFlags = map flagName flags-        traverse_ (checkCondTreeFlags definedFlags) mlib+        mapM_ (checkCondTreeFlags definedFlags . snd) libs         mapM_ (checkCondTreeFlags definedFlags . snd) exes         mapM_ (checkCondTreeFlags definedFlags . snd) tests @@ -1198,24 +1202,39 @@ parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo parseHookedBuildInfo inp = do   fields <- readFields inp-  let ss@(mLibFields:exes) = stanzas fields+  let (mLibFields:rest) = stanzas fields   mLib <- parseLib mLibFields-  biExes <- mapM parseExe (maybe ss (const exes) mLib)-  return (mLib, biExes)+  foldM parseStanza mLib rest   where-    parseLib :: [Field] -> ParseResult (Maybe BuildInfo)+    -- For backwards compatibility, if you have a bare stanza,+    -- we assume it's part of the public library.  We don't+    -- know what the name is, so the people using the HookedBuildInfo+    -- have to handle this carefully.+    parseLib :: [Field] -> ParseResult [(ComponentName, BuildInfo)]     parseLib (bi@(F _ inFieldName _:_))-        | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)-    parseLib _ = return Nothing+        | lowercase inFieldName /= "executable" &&+          lowercase inFieldName /= "library" &&+          lowercase inFieldName /= "benchmark" &&+          lowercase inFieldName /= "test-suite"+            = liftM (\bis -> [(CLibName "", bis)]) (parseBI bi)+    parseLib _ = return [] -    parseExe :: [Field] -> ParseResult (String, BuildInfo)-    parseExe (F line inFieldName mName:bi)-        | lowercase inFieldName == "executable"-            = do bis <- parseBI bi-                 return (mName, bis)-        | otherwise = syntaxError line "expecting 'executable' at top of stanza"-    parseExe (_:_) = cabalBug "`parseExe' called on a non-field"-    parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"+    parseStanza :: HookedBuildInfo -> [Field] -> ParseResult HookedBuildInfo+    parseStanza bis (F line inFieldName mName:bi)+        | Just k <- case lowercase inFieldName of+                        "executable" -> Just CExeName+                        "library"    -> Just CLibName+                        "benchmark"  -> Just CBenchName+                        "test-suite" -> Just CTestName+                        _ -> Nothing+            = do bi' <- parseBI bi+                 return ((k mName, bi'):bis)+        | otherwise+            = syntaxError line $+                "expecting 'executable', 'library', 'benchmark' or 'test-suite' " +++                "at top of stanza, but got '" ++ inFieldName ++ "'"+    parseStanza _ (_:_) = cabalBug "`parseStanza' called on a non-field"+    parseStanza _ [] = syntaxError 0 "error in parsing buildinfo file. Expected stanza"      parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st @@ -1231,9 +1250,7 @@ showPackageDescription pkg = render $      ppPackage pkg   $$ ppCustomFields (customFieldsPD pkg)-  $$ (case library pkg of-        Nothing  -> empty-        Just lib -> ppLibrary lib)+  $$ vcat [ space $$ ppLibrary lib | lib <- libraries pkg ]   $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]   where     ppPackage    = ppFields pkgDescrFieldDescrs@@ -1251,15 +1268,16 @@                              . showHookedBuildInfo  showHookedBuildInfo :: HookedBuildInfo -> String-showHookedBuildInfo (mb_lib_bi, ex_bis) = render $-     (case mb_lib_bi of-        Nothing -> empty-        Just bi -> ppBuildInfo bi)-  $$ vcat [    space-            $$ text "executable:" <+> text name+showHookedBuildInfo bis = render $+     vcat [    space+            $$ ppName name             $$ ppBuildInfo bi-          | (name, bi) <- ex_bis ]+          | (name, bi) <- bis ]   where+    ppName (CLibName name) = text "library:" <+> text name+    ppName (CExeName name) = text "executable:" <+> text name+    ppName (CTestName name) = text "test-suite:" <+> text name+    ppName (CBenchName name) = text "benchmark:" <+> text name     ppBuildInfo bi = ppFields binfoFieldDescrs bi                   $$ ppCustomFields (customFieldsBI bi) @@ -1278,32 +1296,3 @@  --test_findIndentTabs = findIndentTabs $ unlines $ --    [ "foo", "  bar", " \t baz", "\t  biz\t", "\t\t \t mib" ]---- | Dependencies plus module renamings.  This is what users specify; however,--- renaming information is not used for dependency resolution.-data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming-  deriving (Read, Show, Eq, Typeable, Data)--dependency :: DependencyWithRenaming -> Dependency-dependency (DependencyWithRenaming dep _) = dep--instance Text DependencyWithRenaming where-  disp (DependencyWithRenaming d rns) = disp d <+> disp rns-  parse = do d <- parse-             Parse.skipSpaces-             rns <- parse-             Parse.skipSpaces-             return (DependencyWithRenaming d rns)--buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming]-buildDependsWithRenaming pkg =-    map (\dep@(Dependency n _) ->-            DependencyWithRenaming dep-                (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg)))-        (targetBuildDepends pkg)--setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo-setBuildDependsWithRenaming deps pkg = pkg {-    targetBuildDepends = map dependency deps,-    targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps)-  }
cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.PackageDescription.PrettyPrint@@ -18,27 +17,18 @@     showGenericPackageDescription, ) where -#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(mempty))-#endif import Distribution.PackageDescription-       ( Benchmark(..), BenchmarkInterface(..), benchmarkType-       , TestSuite(..), TestSuiteInterface(..), testType-       , SourceRepo(..),-        customFieldsBI, CondTree(..), Condition(..), cNot,-        FlagName(..), ConfVar(..), Executable(..), Library(..),-        Flag(..), PackageDescription(..),-        GenericPackageDescription(..))+import Distribution.Simple.Utils+import Distribution.ParseUtils+import Distribution.PackageDescription.Parse+import Distribution.Package+import Distribution.Text++import Data.Monoid as Mon (Monoid(mempty))+import Data.Maybe (isJust) import Text.PrettyPrint        (hsep, parens, char, nest, empty, isEmpty, ($$), (<+>),         colon, (<>), text, vcat, ($+$), Doc, render)-import Distribution.Simple.Utils (writeUTF8File)-import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)-import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,-       sourceRepoFieldDescrs,flagFieldDescrs)-import Distribution.Package (Dependency(..))-import Distribution.Text (Text(..))-import Data.Maybe (isJust)  -- | Recompile with false for regression testing simplifiedPrinting :: Bool@@ -56,7 +46,8 @@ ppGenericPackageDescription gpd          =         ppPackageDescription (packageDescription gpd)         $+$ ppGenPackageFlags (genPackageFlags gpd)-        $+$ ppLibrary (condLibrary gpd)+        $+$ ppLibraries (unPackageName (packageName (packageDescription gpd)))+                        (condLibraries gpd)         $+$ ppExecutables (condExecutables gpd)         $+$ ppTestSuites (condTestSuites gpd)         $+$ ppBenchmarks (condBenchmarks gpd)@@ -116,10 +107,10 @@   where     fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag -ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc-ppLibrary Nothing                        = empty-ppLibrary (Just condTree)                =-    emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)+ppLibraries :: String -> [(String, CondTree ConfVar [Dependency] Library)] -> Doc+ppLibraries pn libs                           =+    vcat [emptyLine $ text (if n == pn then "library" else "library " ++ n)+              $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs]   where     ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib                             $$  ppCustomFields (customFieldsBI (libBuildInfo lib))@@ -236,9 +227,9 @@            -> Condition ConfVar            -> CondTree ConfVar [Dependency] a            -> Doc-ppIf' it ppIt c thenTree = +ppIf' it ppIt c thenTree =   if isEmpty thenDoc-     then mempty+     then Mon.mempty      else ppIfCondition c $$ nest indentWith thenDoc   where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt @@ -249,7 +240,7 @@               -> Doc ppIfElse it ppIt c thenTree elseTree =   case (isEmpty thenDoc, isEmpty elseDoc) of-    (True,  True)  -> mempty+    (True,  True)  -> Mon.mempty     (False, True)  -> ppIfCondition c $$ nest indentWith thenDoc     (True,  False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc     (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
cabal/Cabal/Distribution/ParseUtils.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.ParseUtils@@ -40,21 +39,17 @@         UnrecFieldParser, warnUnrec, ignoreUnrec,   ) where -import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)+import Distribution.Compiler import Distribution.License import Distribution.Version-         ( Version(..), VersionRange, anyVersion )-import Distribution.Package     ( PackageName(..), Dependency(..) )-import Distribution.ModuleName (ModuleName)+import Distribution.Package+import Distribution.ModuleName+import qualified Distribution.Compat.MonadFail as Fail import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE import Distribution.Text-         ( Text(..) ) import Distribution.Simple.Utils-         ( comparing, dropWhileEndLE, intercalate, lowercase-         , normaliseLineEndings ) import Language.Haskell.Extension-         ( Language, Extension )  import Text.PrettyPrint hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit)@@ -62,9 +57,7 @@ import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map import Control.Monad (foldM, ap)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif+import Control.Applicative as AP (Applicative(..)) import System.FilePath (normalise) import Data.List (sortBy) @@ -98,16 +91,19 @@         fmap f (ParseOk ws x) = ParseOk ws $ f x  instance Applicative ParseResult where-        pure = return+        pure = ParseOk []         (<*>) = ap   instance Monad ParseResult where-        return = ParseOk []+        return = AP.pure         ParseFailed err >>= _ = ParseFailed err         ParseOk ws x >>= f = case f x of                                ParseFailed err -> ParseFailed err                                ParseOk ws' x' -> ParseOk (ws'++ws) x'+        fail = Fail.fail++instance Fail.MonadFail ParseResult where         fail s = ParseFailed (FromString s Nothing)  catchParseError :: ParseResult a -> (PError -> ParseResult a)@@ -660,8 +656,7 @@ parseOptVersion :: ReadP r Version parseOptVersion = parseQuoted ver <++ ver   where ver :: ReadP r Version-        ver = parse <++ return noVersion-        noVersion = Version [] []+        ver = parse <++ return (Version [] [])  parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw
cabal/Cabal/Distribution/Simple.hs view
@@ -56,64 +56,47 @@ -- local import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.UserHooks-import Distribution.Package --must not specify imports, since we're exporting module.-import Distribution.PackageDescription-         ( PackageDescription(..), GenericPackageDescription, Executable(..)-         , updatePackageDescription, hasLibs-         , HookedBuildInfo, emptyHookedBuildInfo )+import Distribution.Package+import Distribution.PackageDescription hiding (Flag) import Distribution.PackageDescription.Parse-         ( readPackageDescription, readHookedBuildInfo ) import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription ) import Distribution.Simple.Program-         ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms-         , restoreProgramConfiguration, reconfigurePrograms )-import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler)+import Distribution.Simple.Program.Db+import Distribution.Simple.PreProcess import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build        ( build, repl )-import Distribution.Simple.SrcDist      ( sdist )+import Distribution.Simple.Build+import Distribution.Simple.SrcDist import Distribution.Simple.Register-         ( register, unregister )  import Distribution.Simple.Configure-         ( getPersistBuildConfig, maybeGetPersistBuildConfig-         , writePersistBuildConfig, checkPersistBuildConfigOutdated-         , configure, checkForeignDeps, findDistPrefOrDefault ) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Bench (bench)-import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Test (test)-import Distribution.Simple.Install (install)-import Distribution.Simple.Haddock (haddock, hscolour)+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Bench+import Distribution.Simple.BuildPaths+import Distribution.Simple.Test+import Distribution.Simple.Install+import Distribution.Simple.Haddock import Distribution.Simple.Utils-         (die, notice, info, warn, setupMessage, chattyTry,-          defaultPackageDesc, defaultHookedPackageDesc,-          rawSystemExitWithEnv, cabalVersion, topHandler )-import Distribution.System-         ( OS(..), buildOS )+import Distribution.Utils.NubList import Distribution.Verbosity import Language.Haskell.Extension import Distribution.Version import Distribution.License import Distribution.Text-         ( display )  -- Base import System.Environment(getArgs, getProgName) import System.Directory(removeFile, doesFileExist,                         doesDirectoryExist, removeDirectoryRecursive) import System.Exit       (exitWith,ExitCode(..))-import System.IO.Error   (isDoesNotExistError)-import Control.Exception (throwIO)+import System.FilePath(searchPathSeparator) import Distribution.Compat.Environment (getEnvironment)-import Distribution.Compat.Exception (catchIO)  import Control.Monad   (when) import Data.Foldable   (traverse_)-import Data.List       (intercalate, unionBy, nub, (\\))+import Data.List       (unionBy)  -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the@@ -322,7 +305,7 @@         flags' = flags { copyDistPref = toFlag distPref }     hookedAction preCopy copyHook postCopy                  (getBuildConfig hooks verbosity distPref)-                 hooks flags' args+                 hooks flags' { copyArgs = args } args  installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args = do@@ -424,19 +407,15 @@    post_hook hooks args flags pkg_descr localbuildinfo  sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()-sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)-    = die $ "The buildinfo contains info for a library, "-         ++ "but the package does not have a library."--sanityCheckHookedBuildInfo pkg_descr (_, hookExes)-    | not (null nonExistant)-    = die $ "The buildinfo contains info for an executable called '"-         ++ head nonExistant ++ "' but the package does not have a "-         ++ "executable with that name."+sanityCheckHookedBuildInfo pkg_descr hooked_bis+    | not (null nonExistentComponents)+    = die $ "The buildinfo contains info for these non-existent components:"+         ++ intercalate ", " (map showComponentName nonExistentComponents)   where-    pkgExeNames  = nub (map exeName (executables pkg_descr))-    hookExeNames = nub (map fst hookExes)-    nonExistant  = hookExeNames \\ pkgExeNames+    nonExistentComponents =+        [ cname+        | (cname, _) <- hooked_bis+        , Nothing <- [lookupComponent pkg_descr cname] ]  sanityCheckHookedBuildInfo _ _ = return () @@ -470,9 +449,9 @@             -- Since the list of unconfigured programs is not serialized,             -- restore it to the same value as normally used at the beginning             -- of a configure run:-            configPrograms = restoreProgramConfiguration+            configPrograms_ = restoreProgramConfiguration                                (builtinPrograms ++ hookedPrograms hooks)-                               (configPrograms cFlags),+                               `fmap` configPrograms_ cFlags,              -- Use the current, not saved verbosity level:             configVerbosity = Flag verbosity@@ -587,12 +566,9 @@     = simpleUserHooks       {        postConf    = defaultPostConf,-       preBuild    = \_ flags ->-                       -- not using 'readHook' here because 'build' takes-                       -- extra args-                       getHookedBuildInfo $ fromFlag $ buildVerbosity flags,+       preBuild    = readHookWithArgs buildVerbosity,+       preCopy     = readHookWithArgs copyVerbosity,        preClean    = readHook cleanVerbosity,-       preCopy     = readHook copyVerbosity,        preInst     = readHook installVerbosity,        preHscolour = readHook hscolourVerbosity,        preHaddock  = readHook haddockVerbosity,@@ -616,6 +592,12 @@            backwardsCompatHack = False +          readHookWithArgs :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo+          readHookWithArgs get_verbosity _ flags = do+              getHookedBuildInfo verbosity+            where+              verbosity = fromFlag (get_verbosity flags)+           readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo           readHook get_verbosity a flags = do               noExtraFlags a@@ -626,7 +608,6 @@ runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo                    -> IO () runConfigureScript verbosity backwardsCompatHack flags lbi = do-   env <- getEnvironment   let programConfig = withPrograms lbi   (ccProg, ccFlags) <- configureCCompiler verbosity programConfig@@ -636,32 +617,25 @@   -- to ccFlags   -- We don't try and tell configure which ld to use, as we don't have   -- a way to pass its flags too-  let env' = appendToEnvironment ("CFLAGS",  unwords ccFlags)-             env-      args' = args ++ ["--with-gcc=" ++ ccProg]-  handleNoWindowsSH $-    rawSystemExitWithEnv verbosity "sh" args' env'+  let extraPath = fromNubList $ configProgramPathExtra flags+  let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ lookup "CFLAGS" env+      spSep = [searchPathSeparator]+      pathEnv = maybe (intercalate spSep extraPath) ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env+      overEnv = ("CFLAGS", Just cflagsEnv) : [("PATH", Just pathEnv) | not (null extraPath)]+      args' = args ++ ["CC=" ++ ccProg]+      shProg = simpleProgram "sh"+      progDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb+  shConfiguredProg <- lookupProgram shProg `fmap` configureProgram  verbosity shProg progDb+  case shConfiguredProg of+      Just sh -> runProgramInvocation verbosity (programInvocation (sh {programOverrideEnv = overEnv}) args')+      Nothing -> die notFoundMsg    where     args = "./configure" : configureArgs backwardsCompatHack flags -    appendToEnvironment (key, val) [] = [(key, val)]-    appendToEnvironment (key, val) (kv@(k, v) : rest)-     | key == k  = (key, v ++ " " ++ val) : rest-     | otherwise = kv : appendToEnvironment (key, val) rest--    handleNoWindowsSH action-      | buildOS /= Windows-      = action--      | otherwise-      = action-          `catchIO` \ioe -> if isDoesNotExistError ioe-                              then die notFoundMsg-                              else throwIO ioe--    notFoundMsg = "The package has a './configure' script. This requires a "-               ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."+    notFoundMsg = "The package has a './configure' script. If you are on Windows, This requires a "+               ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "+               ++ "If you are not on Windows, ensure that an 'sh' command is discoverable in your path."  getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo getHookedBuildInfo verbosity = do@@ -714,6 +688,5 @@ defaultRegHook pkg_descr localbuildinfo _ flags =     if hasLibs pkg_descr     then register pkg_descr localbuildinfo flags-    else setupMessage verbosity+    else setupMessage (fromFlag (regVerbosity flags))            "Package contains no library to register:" (packageId pkg_descr)-  where verbosity = fromFlag (regVerbosity flags)
cabal/Cabal/Distribution/Simple/Bench.hs view
@@ -16,22 +16,17 @@     ) where  import qualified Distribution.PackageDescription as PD-    ( PackageDescription(..), BuildInfo(buildable)-    , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..), localLibraryName )-import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )-import Distribution.Simple.UserHooks ( Args )-import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )+import Distribution.Simple.Setup+import Distribution.Simple.UserHooks+import Distribution.Simple.Utils import Distribution.Text -import Control.Monad ( when, unless )-import System.Exit ( ExitCode(..), exitFailure, exitWith )+import Control.Monad ( when, unless, forM )+import System.Exit ( ExitCode(..), exitFailure, exitSuccess ) import System.Directory ( doesFileExist ) import System.FilePath ( (</>), (<.>) ) @@ -78,9 +73,9 @@                       ++ show (disp $ PD.benchmarkType bm)                   exitFailure -    when (not $ PD.hasBenchmarks pkg_descr) $ do+    unless (PD.hasBenchmarks pkg_descr) $ do         notice verbosity "Package has no benchmarks."-        exitWith ExitSuccess+        exitSuccess      when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $         die $ "No benchmarks enabled. Did you remember to configure with "@@ -88,7 +83,7 @@      bmsToRun <- case benchmarkNames of             [] -> return enabledBenchmarks-            names -> flip mapM names $ \bmName ->+            names -> forM names $ \bmName ->                 let benchmarkMap = zip enabledNames enabledBenchmarks                     enabledNames = map PD.benchmarkName enabledBenchmarks                     allNames = map PD.benchmarkName pkgBenchmarks@@ -123,6 +118,6 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
cabal/Cabal/Distribution/Simple/Build.hs view
@@ -23,6 +23,7 @@     writeAutogenFiles,   ) where +import Distribution.Package import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC   as JHC@@ -32,66 +33,39 @@  import qualified Distribution.Simple.Build.Macros      as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule+import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Package-         ( Package(..), PackageName(..), PackageIdentifier(..)-         , Dependency(..), thisPackageVersion, PackageKey(..), packageName-         , LibraryName(..) )-import Distribution.Simple.Compiler-         ( Compiler, CompilerFlavor(..), compilerFlavor-         , PackageDB(..), PackageDBStack )-import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-         , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..), allBuildInfo, defaultRenaming )+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.PackageDescription hiding (Flag) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName-import Distribution.ModuleName (ModuleName)  import Distribution.Simple.Setup-         ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag ) import Distribution.Simple.BuildTarget-         ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess-         ( preprocessComponent, preprocessExtras, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)-         , Component(..), componentName, getComponent, componentBuildInfo-         , ComponentLocalBuildInfo(..), pkgEnabledComponents-         , withComponentsInBuildOrder, componentsInBuildOrder-         , ComponentName(..), showComponentName-         , ComponentDisabledReason(..), componentDisabledReason-         , inplacePackageId ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db-import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.BuildPaths-         ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )+import Distribution.Simple.Configure import Distribution.Simple.Register-         ( registerPackage, inplaceInstalledPackageInfo )-import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName )+import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, rewriteFile-         , die, info, debug, warn, setupMessage ) -import Distribution.Verbosity-         ( Verbosity )+import Distribution.System import Distribution.Text-         ( display )+import Distribution.Verbosity  import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Either-         ( partitionEithers ) import Data.List-         ( intersect, intercalate )+         ( intersect ) import Control.Monad-         ( when, unless, forM_ )+         ( when, unless ) import System.FilePath          ( (</>), (<.>) ) import System.Directory-         ( getCurrentDirectory, removeDirectoryRecursive, removeFile-         , doesDirectoryExist, doesFileExist )+         ( getCurrentDirectory )  -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package.@@ -107,26 +81,27 @@    targets  <- readBuildTargets pkg_descr (buildArgs flags)   targets' <- checkBuildTargets verbosity pkg_descr targets-  let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))+  let componentsToBuild = componentsInBuildOrder lbi (map fst targets')   info verbosity $ "Component build order: "-                ++ intercalate ", " (map showComponentName componentsToBuild)+                ++ intercalate ", " (map (showComponentName . componentLocalName) componentsToBuild) -  initialBuildSteps distPref pkg_descr lbi verbosity   when (null targets) $     -- Only bother with this message if we're building the whole package     setupMessage verbosity "Building" (packageId pkg_descr)    internalPackageDB <- createInternalPackageDB verbosity lbi distPref -  withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->+  -- TODO: we're computing this twice, do it once!+  withComponentsInBuildOrder pkg_descr lbi (map fst targets') $ \comp clbi -> do+    initialBuildSteps distPref pkg_descr lbi clbi verbosity     let bi     = componentBuildInfo comp         progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)         lbi'   = lbi {                    withPrograms  = progs',                    withPackageDB = withPackageDB lbi ++ [internalPackageDB]                  }-    in buildComponent verbosity (buildNumJobs flags) pkg_descr-                      lbi' suffixes comp clbi distPref+    buildComponent verbosity (buildNumJobs flags) pkg_descr+                   lbi' suffixes comp clbi distPref   repl     :: PackageDescription  -- ^ Mostly information from the .cabal file@@ -149,9 +124,7 @@       componentForRepl  = last componentsToBuild   debug verbosity $ "Component build order: "                  ++ intercalate ", "-                      [ showComponentName c | (c,_) <- componentsToBuild ]--  initialBuildSteps distPref pkg_descr lbi verbosity+                      [ showComponentName (componentLocalName clbi) | clbi <- componentsToBuild ]    internalPackageDB <- createInternalPackageDB verbosity lbi distPref @@ -164,25 +137,30 @@    -- build any dependent components   sequence_-    [ let comp = getComponent pkg_descr cname-          lbi' = lbiForComponent comp lbi-       in buildComponent verbosity NoFlag-                         pkg_descr lbi' suffixes comp clbi distPref-    | (cname, clbi) <- init componentsToBuild ]+    [ do let cname = componentLocalName clbi+             comp = getComponent pkg_descr cname+             lbi' = lbiForComponent comp lbi+         initialBuildSteps distPref pkg_descr lbi clbi verbosity+         buildComponent verbosity NoFlag+                        pkg_descr lbi' suffixes comp clbi distPref+    | clbi <- init componentsToBuild ]    -- REPL for target components-  let (cname, clbi) = componentForRepl+  let clbi = componentForRepl+      cname = componentLocalName clbi       comp = getComponent pkg_descr cname       lbi' = lbiForComponent comp lbi-   in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref+  initialBuildSteps distPref pkg_descr lbi clbi verbosity+  replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref   -- | Start an interpreter without loading any package files.-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()-startInterpreter verbosity programDb comp packageDBs =+startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform+                 -> PackageDBStack -> IO ()+startInterpreter verbosity programDb comp platform packageDBs =   case compilerFlavor comp of-    GHC   -> GHC.startInterpreter   verbosity programDb comp packageDBs-    GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs+    GHC   -> GHC.startInterpreter   verbosity programDb comp platform packageDBs+    GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs     _     -> die "A REPL is not supported with this compiler."  buildComponent :: Verbosity@@ -196,9 +174,9 @@                -> IO () buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CLib lib) clbi distPref = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi-    info verbosity "Building library..."+    info verbosity $ "Building library " ++ libName lib ++ "..."     let libbi = libBuildInfo lib         lib' = lib { libBuildInfo = addExtraCSources libbi extras }     buildLib verbosity numJobs pkg_descr lbi lib' clbi@@ -207,17 +185,15 @@     -- on internally defined libraries.     pwd <- getCurrentDirectory     let -- The in place registration uses the "-inplace" suffix, not an ABI hash-        ipkgid           = inplacePackageId (packageId installedPkgInfo)         installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr-                                                       ipkgid lib' lbi clbi+                                                       (AbiHash "") lib' lbi clbi -    registerPackage verbosity-      installedPkgInfo pkg_descr lbi True -- True meaning in place-      (withPackageDB lbi)+    registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance+                    (withPackageDB lbi) installedPkgInfo  buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     info verbosity $ "Building executable " ++ exeName exe ++ "..."     let ebi = buildInfo exe@@ -229,7 +205,7 @@                comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })                clbi _distPref = do     let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     info verbosity $ "Building test suite " ++ testName test ++ "..."     let ebi = buildInfo exe@@ -249,11 +225,15 @@     pwd <- getCurrentDirectory     let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     info verbosity $ "Building test suite " ++ testName test ++ "..."     buildLib verbosity numJobs pkg lbi lib libClbi-    registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi+    -- NB: need to enable multiple instances here, because on 7.10++    -- the package name is the same as the library, and we still+    -- want the registration to go through.+    registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance+                    (withPackageDB lbi) ipi     let ebi = buildInfo exe         exe' = exe { buildInfo = addExtraCSources ebi extras }     buildExe verbosity numJobs pkg_descr lbi exe' exeClbi@@ -269,7 +249,7 @@                comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })                clbi _ = do     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."     let ebi = buildInfo exe@@ -302,7 +282,7 @@               -> IO () replComponent verbosity pkg_descr lbi suffixes                comp@(CLib lib) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     let libbi = libBuildInfo lib         lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }@@ -310,7 +290,7 @@  replComponent verbosity pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     let ebi = buildInfo exe         exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }@@ -321,7 +301,7 @@                comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })                clbi _distPref = do     let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     let ebi = buildInfo exe         exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }@@ -335,7 +315,7 @@     pwd <- getCurrentDirectory     let (pkg, lib, libClbi, lbi, _, _, _) =           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     let libbi = libBuildInfo lib         lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }@@ -352,7 +332,7 @@                comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })                clbi _ = do     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi-    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes     extras <- preprocessExtras comp lbi     let ebi = buildInfo exe         exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }@@ -397,6 +377,7 @@   where     bi  = testBuildInfo test     lib = Library {+            libName = testName test,             exposedModules = [ m ],             reexportedModules = [],             requiredSignatures = [],@@ -404,24 +385,29 @@             libExposed     = True,             libBuildInfo   = bi           }+    -- This is, like, the one place where we use a CTestName for a library.+    -- Should NOT use library name, since that could conflict!+    PackageIdentifier pkg_name pkg_ver = package pkg_descr+    compat_name = computeCompatPackageName pkg_name (CTestName (testName test))+    compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)     libClbi = LibComponentLocalBuildInfo                 { componentPackageDeps = componentPackageDeps clbi-                , componentPackageRenaming = componentPackageRenaming clbi-                , componentLibraryName = LibraryName (testName test)-                , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]-                , componentPackageKey = OldPackageKey (PackageIdentifier (PackageName (testName test)) (pkgVersion (package pkg_descr)))+                , componentLocalName = CLibName (testName test)+                , componentIsPublic = False+                , componentIncludes = componentIncludes clbi+                , componentUnitId = componentUnitId clbi+                , componentCompatPackageName = compat_name+                , componentCompatPackageKey = compat_key+                , componentExposedModules = [IPI.ExposedModule m Nothing]                 }     pkg = pkg_descr {-            package      = (package pkg_descr) {-                             pkgName = PackageName (testName test)-                           }+            package      = (package pkg_descr) { pkgName = compat_name }           , buildDepends = targetBuildDepends $ testBuildInfo test           , executables  = []           , testSuites   = []-          , library      = Just lib+          , libraries    = [lib]           }-    ipkgid = inplacePackageId (packageId pkg)-    ipi    = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi libClbi+    ipi    = inplaceInstalledPackageInfo pwd distPref pkg (AbiHash "") lib lbi libClbi     testDir = buildDir lbi </> stubName test           </> stubName test ++ "-tmp"     testLibDep = thisPackageVersion $ package pkg@@ -432,22 +418,22 @@                            hsSourceDirs       = [ testDir ],                            targetBuildDepends = testLibDep                              : (targetBuildDepends $ testBuildInfo test),-                           targetBuildRenaming =-                            Map.insert (packageName pkg) defaultRenaming-                                (targetBuildRenaming $ testBuildInfo test)+                           targetBuildRenaming = Map.empty                          }           }     -- | The stub executable needs a new 'ComponentLocalBuildInfo'     -- that exposes the relevant test suite library.+    deps = (IPI.installedUnitId ipi, packageId ipi)+         : (filter (\(_, x) -> let PackageName name = pkgName x+                               in name == "Cabal" || name == "base")+                   (componentPackageDeps clbi))     exeClbi = ExeComponentLocalBuildInfo {-                componentPackageDeps =-                    (IPI.installedPackageId ipi, packageId ipi)-                  : (filter (\(_, x) -> let PackageName name = pkgName x-                                        in name == "Cabal" || name == "base")-                            (componentPackageDeps clbi)),-                componentPackageRenaming =-                    Map.insert (packageName ipi) defaultRenaming-                               (componentPackageRenaming clbi)+                -- TODO: this is a hack, but as long as this is unique+                -- (doesn't clobber something) we won't run into trouble+                componentUnitId = mkUnitId (stubName test),+                componentLocalName = CExeName (stubName test),+                componentPackageDeps = deps,+                componentIncludes = zip (map fst deps) (repeat defaultRenaming)               } testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" @@ -465,8 +451,10 @@             buildInfo  = benchmarkBuildInfo bm           }     exeClbi = ExeComponentLocalBuildInfo {+                componentUnitId = componentUnitId clbi,+                componentLocalName = CExeName (benchmarkName bm),                 componentPackageDeps = componentPackageDeps clbi,-                componentPackageRenaming = componentPackageRenaming clbi+                componentIncludes = componentIncludes clbi               } benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind" @@ -475,24 +463,14 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath                         -> IO PackageDB createInternalPackageDB verbosity lbi distPref = do-    case compilerFlavor (compiler lbi) of-      GHC   -> createWith $ GHC.hcPkgInfo   (withPrograms lbi)-      GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)-      LHC   -> createWith $ LHC.hcPkgInfo   (withPrograms lbi)-      _     -> return packageDB-    where-      dbPath = distPref </> "package.conf.inplace"-      packageDB = SpecificPackageDB dbPath-      createWith hpi = do-        dir_exists <- doesDirectoryExist dbPath-        if dir_exists-            then removeDirectoryRecursive dbPath-            else do file_exists <- doesFileExist dbPath-                    when file_exists $ removeFile dbPath-        if HcPkg.useSingleFileDb hpi-            then writeFile dbPath "[]"-            else HcPkg.init hpi verbosity dbPath-        return packageDB+    existsAlready <- doesPackageDBExist dbPath+    when existsAlready $ deletePackageDB dbPath+    createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath +    return (SpecificPackageDB dbPath)+  where+      dbPath = case compilerFlavor (compiler lbi) of+        UHC -> UHC.inplacePackageDbPath lbi+        _   -> distPref </> "package.conf.inplace"  addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo                       -> ProgramDb -> ProgramDb@@ -559,76 +537,33 @@ initialBuildSteps :: FilePath -- ^"dist" prefix                   -> PackageDescription  -- ^mostly information from the .cabal file                   -> LocalBuildInfo -- ^Configuration information+                  -> ComponentLocalBuildInfo                   -> Verbosity -- ^The verbosity to use                   -> IO ()-initialBuildSteps _distPref pkg_descr lbi verbosity = do+initialBuildSteps _distPref pkg_descr lbi clbi verbosity = do   -- check that there's something to build   unless (not . null $ allBuildInfo pkg_descr) $ do     let name = display (packageId pkg_descr)     die $ "No libraries, executables, tests, or benchmarks "        ++ "are enabled for package " ++ name ++ "." -  createDirectoryIfMissingVerbose verbosity True (buildDir lbi)+  createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) -  writeAutogenFiles verbosity pkg_descr lbi+  writeAutogenFiles verbosity pkg_descr lbi clbi  -- | Generate and write out the Paths_<pkg>.hs and cabal_macros.h files -- writeAutogenFiles :: Verbosity                   -> PackageDescription                   -> LocalBuildInfo+                  -> ComponentLocalBuildInfo                   -> IO ()-writeAutogenFiles verbosity pkg lbi = do-  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi)+writeAutogenFiles verbosity pkg lbi clbi = do+  createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi clbi) -  let pathsModulePath = autogenModulesDir lbi+  let pathsModulePath = autogenModulesDir lbi clbi                     </> ModuleName.toFilePath (autogenModuleName pkg) <.> "hs"-  rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi)--  let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName-  rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)---- | Check that the given build targets are valid in the current context.------ Also swizzle into a more convenient form.----checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]-                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]-checkBuildTargets _ pkg []      =-    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]--checkBuildTargets verbosity pkg targets = do--    let (enabled, disabled) =-          partitionEithers-            [ case componentDisabledReason (getComponent pkg cname) of-                Nothing     -> Left  target'-                Just reason -> Right (cname, reason)-            | target <- targets-            , let target'@(cname,_) = swizzleTarget target ]--    case disabled of-      []                 -> return ()-      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason--    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->-      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "-                    ++ showComponentName c ++ " will be built. (Support for "-                    ++ "module and file targets has not been implemented yet.)"--    return enabled--  where-    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)-    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))-    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))+  rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi clbi) -    formatReason cn DisabledComponent =-        "Cannot build the " ++ cn ++ " because the component is marked "-     ++ "as disabled in the .cabal file."-    formatReason cn DisabledAllTests =-        "Cannot build the " ++ cn ++ " because test suites are not "-     ++ "enabled. Run configure with the flag --enable-tests"-    formatReason cn DisabledAllBenchmarks =-        "Cannot build the " ++ cn ++ " because benchmarks are not "-     ++ "enabled. Re-run configure with the flag --enable-benchmarks"+  let cppHeaderPath = autogenModulesDir lbi clbi </> cppHeaderName+  rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi clbi)
cabal/Cabal/Distribution/Simple/Build/Macros.hs view
@@ -22,37 +22,30 @@     generatePackageVersionMacros,   ) where -import Data.Maybe-         ( isJust ) import Distribution.Package-         ( PackageIdentifier(PackageIdentifier) ) import Distribution.Version-         ( Version(versionBranch) ) import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.Simple.Compiler-         ( packageKeySupported ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(compiler, withPrograms), externalPackageDeps, localPackageKey ) import Distribution.Simple.Program.Db-         ( configuredPrograms ) import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId, programVersion) ) import Distribution.Text-         ( display ) +import Data.Maybe+         ( isJust )+ -- ------------------------------------------------------------ -- * Generate cabal_macros.h -- ------------------------------------------------------------  -- | The contents of the @cabal_macros.h@ for the given configured package. ---generate :: PackageDescription -> LocalBuildInfo -> String-generate _pkg_descr lbi =+generate :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String+generate pkg_descr lbi clbi =   "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++-  generatePackageVersionMacros (map snd (externalPackageDeps lbi)) +++  generatePackageVersionMacros+    (package pkg_descr : map snd (componentPackageDeps clbi)) ++   generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++-  generatePackageKeyMacro lbi+  generateComponentIdMacro lbi clbi  -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of@@ -84,10 +77,10 @@ -- 'generateToolVersionMacros'. -- generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =+generateMacros macro_prefix name version =   concat-  ["#define ", prefix, "VERSION_",name," ",show (display version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ["#define ", macro_prefix, "VERSION_",name," ",show (display version),"\n"+  ,"#define MIN_", macro_prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"   ,"  (major1) <  ",major1," || \\\n"   ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"   ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"@@ -96,14 +89,19 @@   where     (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) --- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key---   of the current package, if supported by the compiler.---   NB: this only makes sense for definite packages.-generatePackageKeyMacro :: LocalBuildInfo -> String-generatePackageKeyMacro lbi-  | packageKeySupported (compiler lbi) =-      "#define CURRENT_PACKAGE_KEY \"" ++ display (localPackageKey lbi) ++ "\"\n\n"-  | otherwise = ""+-- | Generate the @CURRENT_COMPONENT_ID@ definition for the component ID+--   of the current package.+generateComponentIdMacro :: LocalBuildInfo -> ComponentLocalBuildInfo -> String+generateComponentIdMacro lbi clbi =+  concat $+      (case clbi of+        LibComponentLocalBuildInfo{} ->+          ["#define CURRENT_PACKAGE_KEY \"" ++ componentCompatPackageKey clbi ++ "\"\n"]+        _ -> [])+      +++      ["#define CURRENT_COMPONENT_ID \"" ++ display (componentComponentId clbi) ++ "\"\n"+      ,"#define LOCAL_COMPONENT_ID \"" ++ display (localComponentId lbi) ++ "\"\n"+      ,"\n"]  fixchar :: Char -> Char fixchar '-' = '_'
cabal/Cabal/Distribution/Simple/Build/PathsModule.hs view
@@ -19,25 +19,14 @@   ) where  import Distribution.System-         ( OS(Windows), buildOS, Arch(..), buildArch ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Package-         ( packageId, packageName, packageVersion ) import Distribution.PackageDescription-         ( PackageDescription(..), hasLibs ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), InstallDirs(..)-         , absoluteInstallDirs, prefixRelativeInstallDirs )-import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) import Distribution.Simple.BuildPaths-         ( autogenModuleName ) import Distribution.Simple.Utils-         ( shortRelativePath ) import Distribution.Text-         ( display ) import Distribution.Version-         ( Version(..), orLaterVersion, withinRange )  import System.FilePath          ( pathSeparator )@@ -48,11 +37,11 @@ -- * Building Paths_<pkg>.hs -- ------------------------------------------------------------ -generate :: PackageDescription -> LocalBuildInfo -> String-generate pkg_descr lbi =+generate :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String+generate pkg_descr lbi clbi =    let pragmas = cpp_pragma ++ ffi_pragmas ++ warning_pragmas -       cpp_pragma | supports_cpp = "{-# LANGUAGE CPP #-}"+       cpp_pragma | supports_cpp = "{-# LANGUAGE CPP #-}\n"                   | otherwise    = ""         ffi_pragmas@@ -64,7 +53,8 @@           "{-# OPTIONS_JHC -fffi #-}\n"         warning_pragmas =-        "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"+        "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"+++        "{-# OPTIONS_GHC -fno-warn-implicit-prelude #-}\n"         foreign_imports         | absolute = ""@@ -179,6 +169,8 @@    in header++body   where+        cid = componentUnitId clbi+         InstallDirs {           prefix     = flat_prefix,           bindir     = flat_bindir,@@ -186,14 +178,14 @@           datadir    = flat_datadir,           libexecdir = flat_libexecdir,           sysconfdir = flat_sysconfdir-        } = absoluteInstallDirs pkg_descr lbi NoCopyDest+        } = absoluteComponentInstallDirs pkg_descr lbi cid NoCopyDest         InstallDirs {           bindir     = flat_bindirrel,           libdir     = flat_libdirrel,           datadir    = flat_datadirrel,           libexecdir = flat_libexecdirrel,           sysconfdir = flat_sysconfdirrel-        } = prefixRelativeInstallDirs (packageId pkg_descr) lbi+        } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid          flat_bindirreloc = shortRelativePath flat_prefix flat_bindir         flat_libdirreloc = shortRelativePath flat_prefix flat_libdir
cabal/Cabal/Distribution/Simple/BuildPaths.hs view
@@ -31,22 +31,17 @@   ) where  -import System.FilePath ((</>), (<.>))- import Distribution.Package-         ( packageName, LibraryName, getHSLibraryName )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName+import Distribution.ModuleName as ModuleName import Distribution.Compiler-         ( CompilerId(..) )-import Distribution.PackageDescription (PackageDescription)+import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(buildDir) )-import Distribution.Simple.Setup (defaultDistPref)+import Distribution.Simple.Setup import Distribution.Text-         ( display )-import Distribution.System (OS(..), buildOS)+import Distribution.System +import System.FilePath ((</>), (<.>))+ -- --------------------------------------------------------------------------- -- Build directories and files @@ -61,8 +56,10 @@     = distPref </> "doc" </> "html" </> display (packageName pkg_descr)  -- |The directory in which we put auto-generated modules-autogenModulesDir :: LocalBuildInfo -> String-autogenModulesDir lbi = buildDir lbi </> "autogen"+autogenModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String+autogenModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen"+-- NB: Look at 'checkForeignDeps' for where a simplified version of this+-- has been copy-pasted.  cppHeaderName :: String cppHeaderName = "cabal_macros.h"@@ -81,16 +78,16 @@ -- --------------------------------------------------------------------------- -- Library file names -mkLibName :: LibraryName -> String+mkLibName :: UnitId -> String mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a" -mkProfLibName :: LibraryName -> String+mkProfLibName :: UnitId -> String mkProfLibName lib =  "lib" ++ getHSLibraryName lib ++ "_p" <.> "a"  -- Implement proper name mangling for dynamical shared objects -- libHS<packagename>-<compilerFlavour><compilerVersion> -- e.g. libHSbase-2.1-ghc6.6.1.so-mkSharedLibName :: CompilerId -> LibraryName -> String+mkSharedLibName :: CompilerId -> UnitId -> String mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib   = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension   where comp = display compilerFlavor ++ display compilerVersion@@ -99,15 +96,13 @@ -- * Platform file extensions -- ------------------------------------------------------------ --- ToDo: This should be determined via autoconf (AC_EXEEXT)--- | Extension for executable files+-- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: String exeExtension = case buildOS of                    Windows -> "exe"                    _       -> "" --- TODO: This should be determined via autoconf (AC_OBJEXT) -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String objExtension = "o"
cabal/Cabal/Distribution/Simple/BuildTarget.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.BuildTargets@@ -14,10 +14,14 @@     -- * Build targets     BuildTarget(..),     readBuildTargets,+    showBuildTarget,+    QualLevel(..),+    buildTargetComponentName,      -- * Parsing user build targets     UserBuildTarget,     readUserBuildTargets,+    showUserBuildTarget,     UserBuildTargetProblem(..),     reportUserBuildTargetProblems, @@ -25,44 +29,33 @@     resolveBuildTargets,     BuildTargetProblem(..),     reportBuildTargetProblems,-  ) where -import Distribution.Package-         ( Package(..), PackageId, packageName )+    -- * Checking build targets+    checkBuildTargets+  ) where  import Distribution.PackageDescription-         ( PackageDescription-         , Executable(..)-         , TestSuite(..), TestSuiteInterface(..), testModules-         , Benchmark(..), BenchmarkInterface(..), benchmarkModules-         , BuildInfo(..), libModules, exeModules ) import Distribution.ModuleName-         ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo-         ( Component(..), ComponentName(..)-         , pkgComponents, componentName, componentBuildInfo )- import Distribution.Text-         ( display ) import Distribution.Simple.Utils-         ( die, lowercase, equating )+import Distribution.Verbosity +import Distribution.Compat.Binary (Binary)+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+ import Data.List-         ( nub, stripPrefix, sortBy, groupBy, partition, intercalate )-import Data.Ord+         ( nub, stripPrefix, sortBy, groupBy, partition ) import Data.Maybe          ( listToMaybe, catMaybes ) import Data.Either          ( partitionEithers )+import GHC.Generics (Generic) import qualified Data.Map as Map import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Applicative (Alternative(..))-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP-         ( (+++), (<++) )+import Control.Applicative as AP (Alternative(..), Applicative(..)) import Data.Char          ( isSpace, isAlphaNum ) import System.FilePath as FilePath@@ -127,13 +120,19 @@      -- | A specific file within a specific component.      --    | BuildTargetFile ComponentName FilePath-  deriving (Show,Eq)+  deriving (Eq, Show, Generic) +instance Binary BuildTarget --- --------------------------------------------------------------- * Do everything--- ------------------------------------------------------------+buildTargetComponentName :: BuildTarget -> ComponentName+buildTargetComponentName (BuildTargetComponent cn)   = cn+buildTargetComponentName (BuildTargetModule    cn _) = cn+buildTargetComponentName (BuildTargetFile      cn _) = cn +-- | Read a list of user-supplied build target strings and resolve them to+-- 'BuildTarget's according to a 'PackageDescription'. If there are problems+-- with any of the targets e.g. they don't exist or are misformatted, throw an+-- 'IOException'. readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] readBuildTargets pkg targetStrs = do     let (uproblems, utargets) = readUserBuildTargets targetStrs@@ -226,13 +225,17 @@            ++ " - build foo:Data/Foo.hsc  -- file qualified by component"  showUserBuildTarget :: UserBuildTarget -> String-showUserBuildTarget = intercalate ":" . components+showUserBuildTarget = intercalate ":" . getComponents   where-    components (UserBuildTargetSingle s1)       = [s1]-    components (UserBuildTargetDouble s1 s2)    = [s1,s2]-    components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]+    getComponents (UserBuildTargetSingle s1)       = [s1]+    getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]+    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] +showBuildTarget :: QualLevel -> BuildTarget -> String+showBuildTarget ql bt =+    showUserBuildTarget (renderBuildTarget ql bt) + -- ------------------------------------------------------------ -- * Resolving user targets to build targets -- ------------------------------------------------------------@@ -267,7 +270,7 @@       Unambiguous target  -> Right target       Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')                                where targets' = disambiguateBuildTargets-                                                    (packageId pkg) userTarget+                                                    userTarget                                                     targets       None        errs    -> Left (classifyMatchErrors errs) @@ -291,9 +294,9 @@   deriving Show  -disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]+disambiguateBuildTargets :: UserBuildTarget -> [BuildTarget]                          -> [(UserBuildTarget, BuildTarget)]-disambiguateBuildTargets pkgid original =+disambiguateBuildTargets original =     disambiguate (userTargetQualLevel original)   where     disambiguate ql ts@@ -312,13 +315,13 @@             . partition (\g -> length g > 1)             . groupBy (equating fst)             . sortBy (comparing fst)-            . map (\t -> (renderBuildTarget ql t pkgid, t))+            . map (\t -> (renderBuildTarget ql t, t))  data QualLevel = QL1 | QL2 | QL3   deriving (Enum, Show) -renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget-renderBuildTarget ql target pkgid =+renderBuildTarget :: QualLevel -> BuildTarget -> UserBuildTarget+renderBuildTarget ql target =     case ql of       QL1 -> UserBuildTargetSingle s1        where  s1          = single target       QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target@@ -337,7 +340,7 @@     triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)     triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f) -    dispCName = componentStringName pkgid+    dispCName = componentStringName     dispKind  = showComponentKindShort . componentKind  reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()@@ -440,7 +443,7 @@ pkgComponentInfo pkg =     [ ComponentInfo {         cinfoName    = componentName c,-        cinfoStrName = componentStringName pkg (componentName c),+        cinfoStrName = componentStringName (componentName c),         cinfoSrcDirs = hsSourceDirs bi,         cinfoModules = componentModules c,         cinfoHsFiles = componentHsFiles c,@@ -450,11 +453,11 @@     | c <- pkgComponents pkg     , let bi = componentBuildInfo c ] -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName-componentStringName pkg CLibName          = display (packageName pkg)-componentStringName _   (CExeName  name)  = name-componentStringName _   (CTestName  name) = name-componentStringName _   (CBenchName name) = name+componentStringName :: ComponentName -> ComponentStringName+componentStringName (CLibName   name) = name+componentStringName (CExeName   name) = name+componentStringName (CTestName  name) = name+componentStringName (CBenchName name) = name  componentModules :: Component -> [ModuleName] componentModules (CLib   lib)   = libModules lib@@ -494,8 +497,8 @@   deriving (Eq, Ord, Show)  componentKind :: ComponentName -> ComponentKind-componentKind CLibName       = LibKind-componentKind (CExeName  _)  = ExeKind+componentKind (CLibName   _) = LibKind+componentKind (CExeName   _) = ExeKind componentKind (CTestName  _) = TestKind componentKind (CBenchName _) = BenchKind @@ -798,11 +801,12 @@   fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)  instance Applicative Match where-  pure = return+  pure a = ExactMatch 0 [a]   (<*>) = ap  instance Monad Match where-  return a                = ExactMatch 0 [a]+  return = AP.pure+   NoMatch      d ms >>= _ = NoMatch d ms   ExactMatch   d xs >>= f = addDepth d                           $ foldr matchPlus matchZero (map f xs)@@ -937,3 +941,49 @@  caseFold :: String -> String caseFold = lowercase+++-- | Check that the given build targets are valid in the current context.+--+-- Also swizzle into a more convenient form.+--+checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]+                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]+checkBuildTargets _ pkg []      =+    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]++checkBuildTargets verbosity pkg targets = do++    let (enabled, disabled) =+          partitionEithers+            [ case componentDisabledReason (getComponent pkg cname) of+                Nothing     -> Left  target'+                Just reason -> Right (cname, reason)+            | target <- targets+            , let target'@(cname,_) = swizzleTarget target ]++    case disabled of+      []                 -> return ()+      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason++    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->+      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "+                    ++ showComponentName c ++ " will be processed. (Support for "+                    ++ "module and file targets has not been implemented yet.)"++    return enabled++  where+    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)+    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))+    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))++    formatReason cn DisabledComponent =+        "Cannot process the " ++ cn ++ " because the component is marked "+     ++ "as disabled in the .cabal file."+    formatReason cn DisabledAllTests =+        "Cannot process the " ++ cn ++ " because test suites are not "+     ++ "enabled. Run configure with the flag --enable-tests"+    formatReason cn DisabledAllBenchmarks =+        "Cannot process the " ++ cn ++ " because benchmarks are not "+     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
cabal/Cabal/Distribution/Simple/CCompiler.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.CCompiler@@ -47,10 +46,8 @@    filenameCDialect   ) where -#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-     ( Monoid(..) )-#endif+import Distribution.Compat.Semigroup as Semi+ import System.FilePath      ( takeExtension ) @@ -66,15 +63,16 @@  instance Monoid CDialect where   mempty = C--  mappend C                  anything           = anything-  mappend ObjectiveC         CPlusPlus          = ObjectiveCPlusPlus-  mappend CPlusPlus          ObjectiveC         = ObjectiveCPlusPlus-  mappend _                  ObjectiveCPlusPlus = ObjectiveCPlusPlus-  mappend ObjectiveC         _                  = ObjectiveC-  mappend CPlusPlus          _                  = CPlusPlus-  mappend ObjectiveCPlusPlus _                  = ObjectiveCPlusPlus+  mappend = (Semi.<>) +instance Semigroup CDialect where+  C                  <> anything           = anything+  ObjectiveC         <> CPlusPlus          = ObjectiveCPlusPlus+  CPlusPlus          <> ObjectiveC         = ObjectiveCPlusPlus+  _                  <> ObjectiveCPlusPlus = ObjectiveCPlusPlus+  ObjectiveC         <> _                  = ObjectiveC+  CPlusPlus          <> _                  = CPlusPlus+  ObjectiveCPlusPlus <> _                  = ObjectiveCPlusPlus  -- | A list of all file extensions which are recognized as possibly containing --   some dialect of C code.  Note that this list is only for source files,
cabal/Cabal/Distribution/Simple/Command.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Command@@ -6,7 +6,7 @@ -- License     :  BSD3 -- -- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable+-- Portability :  non-portable (ExistentialQuantification) -- -- This is to do with command line handling. The Cabal command line is -- organised into a number of named sub-commands (much like darcs). The@@ -38,6 +38,11 @@   commandAddAction,   noExtraFlags, +  -- ** Building lists of commands+  CommandType(..),+  CommandSpec(..),+  commandFromSpec,+   -- ** Running commands   commandsRun, @@ -60,19 +65,17 @@    ) where -import Control.Monad-import Data.Char (isAlpha, toLower)-import Data.List (sortBy)-import Data.Maybe-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif import qualified Distribution.GetOpt as GetOpt import Distribution.Text-         ( Text(disp, parse) ) import Distribution.ParseUtils import Distribution.ReadE-import Distribution.Simple.Utils (die, intercalate)+import Distribution.Simple.Utils++import Control.Monad+import Data.Char (isAlpha, toLower)+import Data.List (sortBy)+import Data.Maybe+import Data.Monoid as Mon import Text.PrettyPrint ( punctuate, cat, comma, text ) import Text.PrettyPrint as PP ( empty ) @@ -171,7 +174,7 @@     reqArg ad (succeedReadE mkflag) showflag  -- | (String -> a) variant of "optArg"-optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)+optArg' :: Mon.Monoid b => ArgPlaceHolder -> (Maybe String -> b)            -> (b -> [Maybe String])            -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag =@@ -605,3 +608,13 @@     ++ "  " ++ pname ++ " help help\n"     ++ "    Oh, appararently you already know this.\n"   }++-- | wraps a @CommandUI@ together with a function that turns it into a @Command@.+-- By hiding the type of flags for the UI allows construction of a list of all UIs at the+-- top level of the program. That list can then be used for generation of manual page+-- as well as for executing the selected command.+data CommandSpec action+  = forall flags. CommandSpec (CommandUI flags) (CommandUI flags -> Command action) CommandType++commandFromSpec :: CommandSpec a -> Command a+commandFromSpec (CommandSpec ui action _) = action ui
cabal/Cabal/Distribution/Simple/Compiler.hs view
@@ -53,22 +53,25 @@         parmakeSupported,         reexportedModulesSupported,         renamingPackageFlagsSupported,+        unifiedIPIDRequired,         packageKeySupported,+        unitIdSupported,          -- * Support for profiling detail levels         ProfDetailLevel(..),         knownProfDetailLevels,         flagToProfDetailLevel,+        showProfDetailLevel,   ) where  import Distribution.Compiler-import Distribution.Version (Version(..))-import Distribution.Text (display)-import Language.Haskell.Extension (Language(Haskell98), Extension)-import Distribution.Simple.Utils (lowercase)+import Distribution.Version+import Distribution.Text+import Language.Haskell.Extension+import Distribution.Simple.Utils+import Distribution.Compat.Binary  import Control.Monad (liftM)-import Distribution.Compat.Binary (Binary) import Data.List (nub) import qualified Data.Map as M (Map, lookup) import Data.Maybe (catMaybes, isNothing, listToMaybe)@@ -89,7 +92,7 @@         compilerProperties      :: M.Map String String         -- ^ A key-value map for properties not covered by the above fields.     }-    deriving (Generic, Show, Read)+    deriving (Eq, Generic, Show, Read)  instance Binary Compiler @@ -276,10 +279,18 @@ renamingPackageFlagsSupported :: Compiler -> Bool renamingPackageFlagsSupported = ghcSupported "Support thinning and renaming package flags" +-- | Does this compiler have unified IPIDs (so no package keys)+unifiedIPIDRequired :: Compiler -> Bool+unifiedIPIDRequired = ghcSupported "Requires unified installed package IDs"+ -- | Does this compiler support package keys? packageKeySupported :: Compiler -> Bool packageKeySupported = ghcSupported "Uses package keys" +-- | Does this compiler support unit IDs?+unitIdSupported :: Compiler -> Bool+unitIdSupported = ghcSupported "Uses unit IDs"+ -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp =@@ -331,4 +342,13 @@   , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)   , ("all-functions",      ["all"],             ProfDetailAllFunctions)   ]++showProfDetailLevel :: ProfDetailLevel -> String+showProfDetailLevel dl = case dl of+    ProfDetailNone              -> "none"+    ProfDetailDefault           -> "default"+    ProfDetailExportedFunctions -> "exported-functions"+    ProfDetailToplevelFunctions -> "toplevel-functions"+    ProfDetailAllFunctions      -> "all-functions"+    ProfDetailOther other       -> other
cabal/Cabal/Distribution/Simple/Configure.hs view
@@ -1,1755 +1,2134 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-#if __GLASGOW_HASKELL__ >= 711-{-# LANGUAGE PatternSynonyms #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Configure--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This deals with the /configure/ phase. It provides the 'configure' action--- which is given the package description and configure flags. It then tries--- to: configure the compiler; resolves any conditionals in the package--- description; resolve the package dependencies; check if all the extensions--- used by this package are supported by the compiler; check that all the build--- tools are available (including version checks if appropriate); checks for--- any required @pkg-config@ packages (updating the 'BuildInfo' with the--- results)------ Then based on all this it saves the info in the 'LocalBuildInfo' and writes--- it out to the @dist\/setup-config@ file. It also displays various details to--- the user, the amount of information displayed depending on the verbosity--- level.--module Distribution.Simple.Configure (configure,-                                      writePersistBuildConfig,-                                      getConfigStateFile,-                                      getPersistBuildConfig,-                                      checkPersistBuildConfigOutdated,-                                      tryGetPersistBuildConfig,-                                      maybeGetPersistBuildConfig,-                                      findDistPref, findDistPrefOrDefault,-                                      localBuildInfoFile,-                                      getInstalledPackages, getPackageDBContents,-                                      configCompiler, configCompilerAux,-                                      configCompilerEx, configCompilerAuxEx,-                                      ccLdOptionsBuildInfo,-                                      checkForeignDeps,-                                      interpretPackageDbFlags,-                                      ConfigStateFileError(..),-                                      tryGetConfigStateFile,-                                      platformDefines,-                                     )-    where--import Distribution.Compiler-    ( CompilerId(..) )-import Distribution.Utils.NubList-import Distribution.Simple.Compiler-    ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion-    , compilerInfo, ProfDetailLevel(..), knownProfDetailLevels-    , showCompilerId, unsupportedLanguages, unsupportedExtensions-    , PackageDB(..), PackageDBStack, reexportedModulesSupported-    , packageKeySupported, renamingPackageFlagsSupported )-import Distribution.Simple.PreProcess ( platformDefines )-import Distribution.Package-    ( PackageName(PackageName), PackageIdentifier(..), PackageId-    , packageName, packageVersion, Package(..)-    , Dependency(Dependency), simplifyDependency-    , InstalledPackageId(..), thisPackageVersion-    , mkPackageKey, packageKeyLibraryName )-import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription as PD-    ( PackageDescription(..), specVersion, GenericPackageDescription(..)-    , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions-    , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..)-    , ModuleReexport(..) , defaultRenaming )-import Distribution.ModuleName-    ( ModuleName )-import Distribution.PackageDescription.Configuration-    ( finalizePackageDescription, mapTreeData )-import Distribution.PackageDescription.Check-    ( PackageCheck(..), checkPackage, checkPackageFiles )-import Distribution.Simple.Program-    ( Program(..), ProgramLocation(..), ConfiguredProgram(..)-    , ProgramConfiguration, defaultProgramConfiguration-    , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath-    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram-    , userSpecifyArgss, userSpecifyPaths-    , lookupProgram, requireProgram, requireProgramVersion-    , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )-import Distribution.Simple.Setup as Setup-    ( ConfigFlags(..), CopyDest(..), Flag(..), defaultDistPref-    , fromFlag, fromFlagOrDefault, flagToMaybe, toFlag )-import Distribution.Simple.InstallDirs-    ( InstallDirs(..), defaultInstallDirs, combineInstallDirs )-import Distribution.Simple.LocalBuildInfo-    ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId-    , ComponentName(..), showComponentName, pkgEnabledComponents-    , componentBuildInfo, componentName, checkComponentsCyclic )-import Distribution.Simple.BuildPaths-    ( autogenModulesDir )-import Distribution.Simple.Utils-    ( die, warn, info, setupMessage-    , createDirectoryIfMissingVerbose, moreRecentFile-    , intercalate, cabalVersion-    , writeFileAtomic-    , withTempFile )-import Distribution.System-    ( OS(..), buildOS, Platform (..), buildPlatform )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion )-import Distribution.Verbosity-    ( Verbosity, lessVerbose )--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.JHC   as JHC-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite---- Prefer the more generic Data.Traversable.mapM to Prelude.mapM-import Prelude hiding ( mapM )-import Control.Exception-    ( Exception, evaluate, throw, throwIO, try )-#if __GLASGOW_HASKELL__ >= 711-import Control.Exception ( pattern ErrorCall )-#else-import Control.Exception ( ErrorCall(..) )-#endif-import Control.Monad-    ( liftM, when, unless, foldM, filterM )-import Distribution.Compat.Binary ( decodeOrFailIO, encode )-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.List-    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )-import Data.Maybe-    ( isNothing, catMaybes, fromMaybe, isJust )-import Data.Either-    ( partitionEithers )-import qualified Data.Set as Set-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-    ( Monoid(..) )-#endif-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-    ( (</>), isAbsolute )-import qualified System.Info-    ( compilerName, compilerVersion )-import System.IO-    ( hPutStrLn, hClose )-import Distribution.Text-    ( Text(disp), display, simpleParse )-import Text.PrettyPrint-    ( render, (<>), ($+$), char, text, comma-    , quotes, punctuate, nest, sep, hsep )-import Distribution.Compat.Environment ( lookupEnv )-import Distribution.Compat.Exception ( catchExit, catchIO )---- | The errors that can be thrown when reading the @setup-config@ file.-data ConfigStateFileError-    = ConfigStateFileNoHeader -- ^ No header found.-    | ConfigStateFileBadHeader -- ^ Incorrect header.-    | ConfigStateFileNoParse -- ^ Cannot parse file contents.-    | ConfigStateFileMissing -- ^ No file!-    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.-  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---- | 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.-getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                   -> IO LocalBuildInfo-getConfigStateFile filename = do-    exists <- doesFileExist filename-    unless exists $ throwIO ConfigStateFileMissing-    -- Read the config file into a strict ByteString to avoid problems with-    -- lazy I/O, then convert to lazy because the binary package needs that.-    contents <- BS.readFile filename-    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])--    headerParseResult <- try $ evaluate $ parseHeader header-    let (cabalId, compId) =-            case headerParseResult of-              Left (ErrorCall _) -> throw ConfigStateFileBadHeader-              Right x -> x--    let getStoredValue = do-          result <- decodeOrFailIO (BLC8.tail body)-          case result of-            Left _ -> throw ConfigStateFileNoParse-            Right x -> return x-        deferErrorIfBadVersion act-          | cabalId /= currentCabalId = do-              eResult <- try act-              throw $ ConfigStateFileBadVersion cabalId compId eResult-          | otherwise = act-    deferErrorIfBadVersion getStoredValue---- | Read the 'localBuildInfoFile', returning either an error or the local build info.-tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.-                      -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetConfigStateFile = try . getConfigStateFile---- | Try to read the 'localBuildInfoFile'.-tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                         -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetPersistBuildConfig = try . getPersistBuildConfig---- | 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 -- ^ The @dist@ directory path.-                      -> IO LocalBuildInfo-getPersistBuildConfig = getConfigStateFile . localBuildInfoFile---- | Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                           -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig =-    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig---- | After running configure, output the 'LocalBuildInfo' to the--- 'localBuildInfoFile'.-writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.-                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.-                        -> IO ()-writePersistBuildConfig distPref lbi = do-    createDirectoryIfMissing False distPref-    writeFileAtomic (localBuildInfoFile distPref) $-      BLC8.unlines [showHeader pkgId, encode lbi]-  where-    pkgId = packageId $ localPkgDescr lbi---- | Identifier of the current Cabal package.-currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion---- | Identifier of the current compiler package.-currentCompilerId :: PackageIdentifier-currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)-                                      System.Info.compilerVersion---- | Parse the @setup-config@ file header, returning the package identifiers --- for Cabal and the compiler.-parseHeader :: ByteString -- ^ The file contents.-            -> (PackageIdentifier, PackageIdentifier)-parseHeader header = case BLC8.words header of-  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] ->-      fromMaybe (throw ConfigStateFileBadHeader) $ do-          _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier-          cabalId' <- simpleParse (BLC8.unpack cabalId)-          compId' <- simpleParse (BLC8.unpack compId)-          return (cabalId', compId')-  _ -> throw ConfigStateFileNoHeader---- | Generate the @setup-config@ file header.-showHeader :: PackageIdentifier -- ^ The processed package.-            -> ByteString-showHeader pkgId = BLC8.unwords-    [ "Saved", "package", "config", "for"-    , BLC8.pack $ display pkgId-    , "written", "by"-    , BLC8.pack $ display currentCabalId-    , "using"-    , BLC8.pack $ display currentCompilerId-    ]---- | Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-checkPersistBuildConfigOutdated distPref pkg_descr_file = do-  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)---- | Get the path of @dist\/setup-config@.-localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.-                    -> FilePath-localBuildInfoFile distPref = distPref </> "setup-config"---- -------------------------------------------------------------------------------- * Configuration--- --------------------------------------------------------------------------------- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken from--- (in order of highest to lowest preference) the override prefix, the \"CABAL_BUILDDIR\"--- environment variable, or the default prefix.-findDistPref :: FilePath  -- ^ default \"dist\" prefix-             -> Setup.Flag FilePath  -- ^ override \"dist\" prefix-             -> IO FilePath-findDistPref defDistPref overrideDistPref = do-    envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")-    return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)-  where-    parseEnvDistPref env =-      case env of-        Just distPref | not (null distPref) -> toFlag distPref-        _ -> NoFlag---- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken from--- (in order of highest to lowest preference) the override prefix, the \"CABAL_BUILDDIR\"--- environment variable, or 'defaultDistPref' is used. Call this function to resolve a--- @*DistPref@ flag whenever it is not known to be set. (The @*DistPref@ flags are always--- set to a definite value before invoking 'UserHooks'.)-findDistPrefOrDefault :: Setup.Flag FilePath  -- ^ override \"dist\" prefix-                      -> IO FilePath-findDistPrefOrDefault = findDistPref defaultDistPref---- |Perform the \"@.\/setup configure@\" action.--- Returns the @.setup-config@ file.-configure :: (GenericPackageDescription, HookedBuildInfo)-          -> ConfigFlags -> IO LocalBuildInfo-configure (pkg_descr0, pbi) cfg-  = do  let distPref = fromFlag (configDistPref cfg)-            buildDir' = distPref </> "build"--        setupMessage verbosity "Configuring" (packageId pkg_descr0)--        unless (configProfExe cfg == NoFlag) $ do-          let enable | fromFlag (configProfExe cfg) = "enable"-                     | otherwise = "disable"-          warn verbosity-            ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "-             ++ "Please use --" ++ enable ++ "-profiling instead.")--        unless (configLibCoverage cfg == NoFlag) $ do-          let enable | fromFlag (configLibCoverage cfg) = "enable"-                     | otherwise = "disable"-          warn verbosity-            ("The flag --" ++ enable ++ "-library-coverage is deprecated. "-             ++ "Please use --" ++ enable ++ "-coverage instead.")--        createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref--        let programsConfig = mkProgramsConfig cfg (configPrograms cfg)-            userInstall    = fromFlag (configUserInstall cfg)-            packageDbs     = interpretPackageDbFlags userInstall-                             (configPackageDBs cfg)--        -- detect compiler-        (comp, compPlatform, programsConfig') <- configCompilerEx-          (flagToMaybe $ configHcFlavor cfg)-          (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)-          programsConfig (lessVerbose verbosity)-        let version = compilerVersion comp-            flavor  = compilerFlavor comp--        -- Create a PackageIndex that makes *any libraries that might be*-        -- defined internally to this package look like installed packages, in-        -- case an executable should refer to any of them as dependencies.-        ---        -- It must be *any libraries that might be* defined rather than the-        -- actual definitions, because these depend on conditionals in the .cabal-        -- file, and we haven't resolved them yet.  finalizePackageDescription-        -- does the resolution of conditionals, and it takes internalPackageSet-        -- as part of its input.-        ---        -- Currently a package can define no more than one library (which has-        -- the same name as the package) but we could extend this later.-        -- If we later allowed private internal libraries, then here we would-        -- need to pre-scan the conditional data to make a list of all private-        -- libraries that could possibly be defined by the .cabal file.-        let pid = packageId pkg_descr0-            internalPackage = emptyInstalledPackageInfo {-                --TODO: should use a per-compiler method to map the source-                --      package ID into an installed package id we can use-                --      for the internal package set. The open-codes use of-                --      InstalledPackageId . display here is a hack.-                Installed.installedPackageId =-                   InstalledPackageId $ display $ pid,-                Installed.sourcePackageId = pid-              }-            internalPackageSet = PackageIndex.fromList [internalPackage]-        installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp-                                      packageDbs programsConfig'--        (allConstraints, requiredDepsMap) <- either die return $-          combinedConstraints (configConstraints cfg)-                              (configDependencies cfg)-                              installedPackageSet--        let exactConf = fromFlagOrDefault False (configExactConfiguration cfg)-            -- Constraint test function for the solver-            dependencySatisfiable d@(Dependency depName verRange)-              | exactConf =-                -- When we're given '--exact-configuration', we assume that all-                -- dependencies and flags are exactly specified on the command-                -- line. Thus we only consult the 'requiredDepsMap'. Note that-                -- we're not doing the version range check, so if there's some-                -- dependency that wasn't specified on the command line,-                -- 'finalizePackageDescription' will fail.-                ---                -- TODO: mention '--exact-configuration' in the error message-                -- when this fails?-                (depName `Map.member` requiredDepsMap) || isInternalDep--              | otherwise =-                -- Normal operation: just look up dependency in the package-                -- index.-                not . null . PackageIndex.lookupDependency pkgs' $ d-              where-                pkgs' = PackageIndex.insert internalPackage installedPackageSet-                isInternalDep = pkgName pid == depName-                                && pkgVersion pid `withinRange` verRange-            enableTest t = t { testEnabled = fromFlag (configTests cfg) }-            flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))-                               (condTestSuites pkg_descr0)-            enableBenchmark bm = bm { benchmarkEnabled =-                                         fromFlag (configBenchmarks cfg) }-            flaggedBenchmarks = map (\(n, bm) ->-                                      (n, mapTreeData enableBenchmark bm))-                               (condBenchmarks pkg_descr0)-            pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests-                                      , condBenchmarks = flaggedBenchmarks }--        (pkg_descr0', flags) <--                case finalizePackageDescription-                       (configConfigurationsFlags cfg)-                       dependencySatisfiable-                       compPlatform-                       (compilerInfo comp)-                       allConstraints-                       pkg_descr0''-                of Right r -> return r-                   Left missing ->-                       die $ "At least the following dependencies are missing:\n"-                         ++ (render . nest 4 . sep . punctuate comma-                                    . map (disp . simplifyDependency)-                                    $ missing)--        -- Sanity check: if '--exact-configuration' was given, ensure that the-        -- complete flag assignment was specified on the command line.-        when exactConf $ do-          let cmdlineFlags = map fst (configConfigurationsFlags cfg)-              allFlags     = map flagName . genPackageFlags $ pkg_descr0-              diffFlags    = allFlags \\ cmdlineFlags-          when (not . null $ diffFlags) $-            die $ "'--exact-conf' was given, "-            ++ "but the following flags were not specified: "-            ++ intercalate ", " (map show diffFlags)--        -- add extra include/lib dirs as specified in cfg-        -- we do it here so that those get checked too-        let pkg_descr = addExtraIncludeLibDirs pkg_descr0'--        unless (renamingPackageFlagsSupported comp ||-                    and [ rn == defaultRenaming-                        | bi <- allBuildInfo pkg_descr-                        , rn <- Map.elems (targetBuildRenaming bi)]) $-            die $ "Your compiler does not support thinning and renaming on "-               ++ "package flags.  To use this feature you probably must use "-               ++ "GHC 7.9 or later."--        when (not (null flags)) $-          info verbosity $ "Flags chosen: "-                        ++ intercalate ", " [ name ++ "=" ++ display value-                                            | (FlagName name, value) <- flags ]--        when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr)-              && not (reexportedModulesSupported comp)) $ do-            die $ "Your compiler does not support module re-exports. To use "-               ++ "this feature you probably must use GHC 7.9 or later."--        checkPackageProblems verbosity pkg_descr0-          (updatePackageDescription pbi pkg_descr)--        -- Handle hole instantiation-        (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet--        let selectDependencies :: [Dependency] ->-                                  ([FailedDependency], [ResolvedDependency])-            selectDependencies =-                (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))-              . map (selectDependency internalPackageSet installedPackageSet-                                      requiredDepsMap)--            (failedDeps, allPkgDeps) =-              selectDependencies (buildDepends pkg_descr)--            internalPkgDeps = [ pkgid-                              | InternalDependency _ pkgid <- allPkgDeps ]-            externalPkgDeps = [ pkg-                              | ExternalDependency _ pkg   <- allPkgDeps ]--        when (not (null internalPkgDeps)-              && not (newPackageDepsBehaviour pkg_descr)) $-            die $ "The field 'build-depends: "-               ++ intercalate ", " (map (display . packageName) internalPkgDeps)-               ++ "' refers to a library which is defined within the same "-               ++ "package. To use this feature the package must specify at "-               ++ "least 'cabal-version: >= 1.8'."--        reportFailedDependencies failedDeps-        reportSelectedDependencies verbosity allPkgDeps--        let installDeps = Map.elems-                        . Map.fromList-                        . map (\v -> (Installed.installedPackageId v, v))-                        $ externalPkgDeps ++ holeDeps--        packageDependsIndex <--          case PackageIndex.dependencyClosure installedPackageSet-                  (map Installed.installedPackageId installDeps) of-            Left packageDependsIndex -> return packageDependsIndex-            Right broken ->-              die $ "The following installed packages are broken because other"-                 ++ " packages they depend on are missing. These broken "-                 ++ "packages must be rebuilt before they can be used.\n"-                 ++ unlines [ "package "-                           ++ display (packageId pkg)-                           ++ " is broken due to missing package "-                           ++ intercalate ", " (map display deps)-                            | (pkg, deps) <- broken ]--        let pseudoTopPkg = emptyInstalledPackageInfo {-                Installed.installedPackageId =-                   InstalledPackageId (display (packageId pkg_descr)),-                Installed.sourcePackageId = packageId pkg_descr,-                Installed.depends =-                  map Installed.installedPackageId installDeps-              }-        case PackageIndex.dependencyInconsistencies-           . PackageIndex.insert pseudoTopPkg-           $ packageDependsIndex of-          [] -> return ()-          inconsistencies ->-            warn verbosity $-                 "This package indirectly depends on multiple versions of the same "-              ++ "package. This is highly likely to cause a compile failure.\n"-              ++ unlines [ "package " ++ display pkg ++ " requires "-                        ++ display (PackageIdentifier name ver)-                         | (name, uses) <- inconsistencies-                         , (pkg, ver) <- uses ]--        -- installation directories-        defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)-        let installDirs = combineInstallDirs fromFlagOrDefault-                            defaultDirs (configInstallDirs cfg)--        -- check languages and extensions-        let langlist = nub $ catMaybes $ map defaultLanguage-                       (allBuildInfo pkg_descr)-        let langs = unsupportedLanguages comp langlist-        when (not (null langs)) $-          die $ "The package " ++ display (packageId pkg_descr0)-             ++ " requires the following languages which are not "-             ++ "supported by " ++ display (compilerId comp) ++ ": "-             ++ intercalate ", " (map display langs)-        let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr)-        let exts = unsupportedExtensions comp extlist-        when (not (null exts)) $-          die $ "The package " ++ display (packageId pkg_descr0)-             ++ " requires the following language extensions which are not "-             ++ "supported by " ++ display (compilerId comp) ++ ": "-             ++ intercalate ", " (map display exts)--        -- configured known/required programs & external build tools-        -- exclude build-tool deps on "internal" exes in the same package-        let requiredBuildTools =-              [ buildTool-              | let exeNames = map exeName (executables pkg_descr)-              , bi <- allBuildInfo pkg_descr-              , buildTool@(Dependency (PackageName toolName) reqVer)-                <- buildTools bi-              , let isInternal =-                        toolName `elem` exeNames-                        -- we assume all internal build-tools are-                        -- versioned with the package:-                     && packageVersion pkg_descr `withinRange` reqVer-              , not isInternal ]--        programsConfig'' <--              configureAllKnownPrograms (lessVerbose verbosity) programsConfig'-          >>= configureRequiredPrograms verbosity requiredBuildTools--        (pkg_descr', programsConfig''') <--          configurePkgconfigPackages verbosity pkg_descr programsConfig''--        -- internal component graph-        buildComponents <--          case mkComponentsGraph pkg_descr internalPkgDeps of-            Left  componentCycle -> reportComponentCycle componentCycle-            Right components     ->-              mkComponentsLocalBuildInfo comp packageDependsIndex pkg_descr-                                         internalPkgDeps externalPkgDeps holeDeps-                                         (Map.fromList hole_insts)-                                         components--        split_objs <--           if not (fromFlag $ configSplitObjs cfg)-                then return False-                else case flavor of-                            GHC | version >= Version [6,5] [] -> return True-                            GHCJS                             -> return True-                            _ -> do warn verbosity-                                         ("this compiler does not support " ++-                                          "--enable-split-objs; ignoring")-                                    return False--        let ghciLibByDefault =-              case compilerId comp of-                CompilerId GHC _ ->-                  -- If ghc is non-dynamic, then ghci needs object files,-                  -- so we build one by default.-                  ---                  -- Technically, archive files should be sufficient for ghci,-                  -- but because of GHC bug #8942, it has never been safe to-                  -- rely on them. By the time that bug was fixed, ghci had-                  -- been changed to read shared libraries instead of archive-                  -- files (see next code block).-                  not (GHC.isDynamic comp)-                CompilerId GHCJS _ ->-                  not (GHCJS.isDynamic comp)-                _ -> False--        let sharedLibsByDefault-              | fromFlag (configDynExe cfg) =-                  -- build a shared library if dynamically-linked-                  -- executables are requested-                  True-              | otherwise = case compilerId comp of-                CompilerId GHC _ ->-                  -- if ghc is dynamic, then ghci needs a shared-                  -- library, so we build one by default.-                  GHC.isDynamic comp-                CompilerId GHCJS _ ->-                  GHCJS.isDynamic comp-                _ -> False-            withSharedLib_ =-                -- build shared libraries if required by GHC or by the-                -- executable linking mode, but allow the user to force-                -- building only static library archives with-                -- --disable-shared.-                fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg-            withDynExe_ = fromFlag $ configDynExe cfg-        when (withDynExe_ && not withSharedLib_) $ warn verbosity $-               "Executables will use dynamic linking, but a shared library "-            ++ "is not being built. Linking will fail if any executables "-            ++ "depend on the library."--        -- The --profiling flag sets the default for both libs and exes,-        -- but can be overidden by --library-profiling, or the old deprecated-        -- --executable-profiling flag.-        let profEnabledLibOnly = configProfLib cfg-            profEnabledBoth    = fromFlagOrDefault False (configProf cfg)-            profEnabledLib = fromFlagOrDefault profEnabledBoth profEnabledLibOnly-            profEnabledExe = fromFlagOrDefault profEnabledBoth (configProfExe cfg)--        -- The --profiling-detail and --library-profiling-detail flags behave-        -- similarly-        profDetailLibOnly <- checkProfDetail (configProfLibDetail cfg)-        profDetailBoth    <- liftM (fromFlagOrDefault ProfDetailDefault)-                                   (checkProfDetail (configProfDetail cfg))-        let profDetailLib = fromFlagOrDefault profDetailBoth profDetailLibOnly-            profDetailExe = profDetailBoth--        when (profEnabledExe && not profEnabledLib) $-          warn verbosity $-               "Executables will be built with profiling, but library "-            ++ "profiling is disabled. Linking will fail if any executables "-            ++ "depend on the library."--        let configCoverage_ =-              mappend (configCoverage cfg) (configLibCoverage cfg)--            cfg' = cfg { configCoverage = configCoverage_ }--        reloc <--           if not (fromFlag $ configRelocatable cfg)-                then return False-                else return True--        let lbi = LocalBuildInfo {-                    configFlags         = cfg',-                    extraConfigArgs     = [],  -- Currently configure does not-                                               -- take extra args, but if it-                                               -- did they would go here.-                    installDirTemplates = installDirs,-                    compiler            = comp,-                    hostPlatform        = compPlatform,-                    buildDir            = buildDir',-                    componentsConfigs   = buildComponents,-                    installedPkgs       = packageDependsIndex,-                    pkgDescrFile        = Nothing,-                    localPkgDescr       = pkg_descr',-                    instantiatedWith    = hole_insts,-                    withPrograms        = programsConfig''',-                    withVanillaLib      = fromFlag $ configVanillaLib cfg,-                    withProfLib         = profEnabledLib,-                    withSharedLib       = withSharedLib_,-                    withDynExe          = withDynExe_,-                    withProfExe         = profEnabledExe,-                    withProfLibDetail   = profDetailLib,-                    withProfExeDetail   = profDetailExe,-                    withOptimization    = fromFlag $ configOptimization cfg,-                    withDebugInfo       = fromFlag $ configDebugInfo cfg,-                    withGHCiLib         = fromFlagOrDefault ghciLibByDefault $-                                          configGHCiLib cfg,-                    splitObjs           = split_objs,-                    stripExes           = fromFlag $ configStripExes cfg,-                    stripLibs           = fromFlag $ configStripLibs cfg,-                    withPackageDB       = packageDbs,-                    progPrefix          = fromFlag $ configProgPrefix cfg,-                    progSuffix          = fromFlag $ configProgSuffix cfg,-                    relocatable         = reloc-                  }--        when reloc (checkRelocatable verbosity pkg_descr lbi)--        let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest-            relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi--        unless (isAbsolute (prefix dirs)) $ die $-            "expected an absolute directory name for --prefix: " ++ prefix dirs--        info verbosity $ "Using " ++ display currentCabalId-                      ++ " compiled by " ++ display currentCompilerId-        info verbosity $ "Using compiler: " ++ showCompilerId comp-        info verbosity $ "Using install prefix: " ++ prefix dirs--        let dirinfo name dir isPrefixRelative =-              info verbosity $ name ++ " installed in: " ++ dir ++ relNote-              where relNote = case buildOS of-                      Windows | not (hasLibs pkg_descr)-                             && isNothing isPrefixRelative-                             -> "  (fixed location)"-                      _      -> ""--        dirinfo "Binaries"         (bindir dirs)     (bindir relative)-        dirinfo "Libraries"        (libdir dirs)     (libdir relative)-        dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)-        dirinfo "Data files"       (datadir dirs)    (datadir relative)-        dirinfo "Documentation"    (docdir dirs)     (docdir relative)-        dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)--        sequence_ [ reportProgram verbosity prog configuredProg-                  | (prog, configuredProg) <- knownPrograms programsConfig''' ]--        return lbi--    where-      verbosity = fromFlag (configVerbosity cfg)--      addExtraIncludeLibDirs pkg_descr =-          let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg-                               , PD.includeDirs = configExtraIncludeDirs cfg}-              modifyLib l        = l{ libBuildInfo = libBuildInfo l-                                                     `mappend` extraBi }-              modifyExecutable e = e{ buildInfo    = buildInfo e-                                                     `mappend` extraBi}-          in pkg_descr{ library     = modifyLib        `fmap` library pkg_descr-                      , executables = modifyExecutable  `map`-                                      executables pkg_descr}--      checkProfDetail (Flag (ProfDetailOther other)) = do-        warn verbosity $-             "Unknown profiling detail level '" ++ other-          ++ "', using default.\n"-          ++ "The profiling detail levels are: " ++ intercalate ", "-             [ name | (name, _, _) <- knownProfDetailLevels ]-        return (Flag ProfDetailDefault)-      checkProfDetail other = return other--mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration-mkProgramsConfig cfg initialProgramsConfig = programsConfig-  where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   . setProgramSearchPath searchpath-                   $ initialProgramsConfig-    searchpath     = getProgramSearchPath (initialProgramsConfig)-                  ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg)---- -------------------------------------------------------------------------------- Configuring package dependencies--reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO ()-reportProgram verbosity prog Nothing-    = info verbosity $ "No " ++ programName prog ++ " found"-reportProgram verbosity prog (Just configuredProg)-    = info verbosity $ "Using " ++ programName prog ++ version ++ location-    where location = case programLocation configuredProg of-            FoundOnSystem p -> " found on system at: " ++ p-            UserSpecified p -> " given by user at: " ++ p-          version = case programVersion configuredProg of-            Nothing -> ""-            Just v  -> " version " ++ display v--hackageUrl :: String-hackageUrl = "http://hackage.haskell.org/package/"--data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo-                        | InternalDependency Dependency PackageId -- should be a-                                                                      -- lib name--data FailedDependency = DependencyNotExists PackageName-                      | DependencyNoVersion Dependency---- | Test for a package dependency and record the version we have installed.-selectDependency :: InstalledPackageIndex  -- ^ Internally defined packages-                 -> InstalledPackageIndex  -- ^ Installed packages-                 -> Map PackageName InstalledPackageInfo-                    -- ^ Packages for which we have been given specific deps to use-                 -> Dependency-                 -> Either FailedDependency ResolvedDependency-selectDependency internalIndex installedIndex requiredDepsMap-  dep@(Dependency pkgname vr) =-  -- If the dependency specification matches anything in the internal package-  -- index, then we prefer that match to anything in the second.-  -- For example:-  ---  -- Name: MyLibrary-  -- Version: 0.1-  -- Library-  --     ..-  -- Executable my-exec-  --     build-depends: MyLibrary-  ---  -- We want "build-depends: MyLibrary" always to match the internal library-  -- even if there is a newer installed library "MyLibrary-0.2".-  -- However, "build-depends: MyLibrary >= 0.2" should match the installed one.-  case PackageIndex.lookupPackageName internalIndex pkgname of-    [(_,[pkg])] | packageVersion pkg `withinRange` vr-           -> Right $ InternalDependency dep (packageId pkg)--    _      -> case Map.lookup pkgname requiredDepsMap of-      -- If we know the exact pkg to use, then use it.-      Just pkginstance -> Right (ExternalDependency dep pkginstance)-      -- Otherwise we just pick an arbitrary instance of the latest version.-      Nothing -> case PackageIndex.lookupDependency installedIndex dep of-        []   -> Left  $ DependencyNotExists pkgname-        pkgs -> Right $ ExternalDependency dep $-                case last pkgs of-                  (_ver, pkginstances) -> head pkginstances--reportSelectedDependencies :: Verbosity-                           -> [ResolvedDependency] -> IO ()-reportSelectedDependencies verbosity deps =-  info verbosity $ unlines-    [ "Dependency " ++ display (simplifyDependency dep)-                    ++ ": using " ++ display pkgid-    | resolved <- deps-    , let (dep, pkgid) = case resolved of-            ExternalDependency dep' pkg'   -> (dep', packageId pkg')-            InternalDependency dep' pkgid' -> (dep', pkgid') ]--reportFailedDependencies :: [FailedDependency] -> IO ()-reportFailedDependencies []     = return ()-reportFailedDependencies failed =-    die (intercalate "\n\n" (map reportFailedDependency failed))--  where-    reportFailedDependency (DependencyNotExists pkgname) =-         "there is no version of " ++ display pkgname ++ " installed.\n"-      ++ "Perhaps you need to download and install it from\n"-      ++ hackageUrl ++ display pkgname ++ "?"--    reportFailedDependency (DependencyNoVersion dep) =-        "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"---- | List all installed packages in the given package databases.-getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -- ^ The stack of package databases.-                     -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDBs progconf = do-  when (null packageDBs) $-    die $ "No package databases have been specified. If you use "-       ++ "--package-db=clear, you must follow it with --package-db= "-       ++ "with 'global', 'user' or a specific file."--  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackages verbosity comp packageDBs progconf-    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf-    JHC   -> JHC.getInstalledPackages verbosity packageDBs progconf-    LHC   -> LHC.getInstalledPackages verbosity packageDBs progconf-    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progconf-    HaskellSuite {} ->-      HaskellSuite.getInstalledPackages verbosity packageDBs progconf-    flv -> die $ "don't know how to find the installed packages for "-              ++ display flv---- | Like 'getInstalledPackages', but for a single package DB.-getPackageDBContents :: Verbosity -> Compiler-                     -> PackageDB -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity comp packageDB progconf = do-  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC -> GHC.getPackageDBContents verbosity packageDB progconf-    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf-    -- For other compilers, try to fall back on 'getInstalledPackages'.-    _   -> getInstalledPackages verbosity comp [packageDB] progconf----- | The user interface specifies the package dbs to use with a combination of--- @--global@, @--user@ and @--package-db=global|user|clear|$file@.--- This function combines the global/user flag and interprets the package-db--- flag into a single package db stack.----interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack-interpretPackageDbFlags userInstall specificDBs =-    extra initialStack specificDBs-  where-    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]-                 | otherwise   = [GlobalPackageDB]--    extra dbs' []            = dbs'-    extra _    (Nothing:dbs) = extra []             dbs-    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs--newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version [1,7,1] []---- In older cabal versions, there was only one set of package dependencies for--- the whole package. In this version, we can have separate dependencies per--- target, but we only enable this behaviour if the minimum cabal version--- specified is >= a certain minimum. Otherwise, for compatibility we use the--- old behaviour.-newPackageDepsBehaviour :: PackageDescription -> Bool-newPackageDepsBehaviour pkg =-   specVersion pkg >= newPackageDepsBehaviourMinVersion---- We are given both --constraint="foo < 2.0" style constraints and also--- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".------ When finalising the package we have to take into account the specific--- installed deps we've been given, and the finalise function expects--- constraints, so we have to translate these deps into version constraints.------ But after finalising we then have to make sure we pick the right specific--- deps in the end. So we still need to remember which installed packages to--- pick.-combinedConstraints :: [Dependency] ->-                       [(PackageName, InstalledPackageId)] ->-                       InstalledPackageIndex ->-                       Either String ([Dependency],-                                      Map PackageName InstalledPackageInfo)-combinedConstraints constraints dependencies installedPackages = do--    when (not (null badInstalledPackageIds)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badInstalledPackageIds)-         $+$ text "however the given installed package instance does not exist."--    when (not (null badNames)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badNames)-         $+$ text "however the installed package's name does not match the name given."--    --TODO: we don't check that all dependencies are used!--    return (allConstraints, idConstraintMap)--  where-    allConstraints :: [Dependency]-    allConstraints = constraints-                  ++ [ thisPackageVersion (packageId pkg)-                     | (_, _, Just pkg) <- dependenciesPkgInfo ]--    idConstraintMap :: Map PackageName InstalledPackageInfo-    idConstraintMap = Map.fromList-                        [ (packageName pkg, pkg)-                        | (_, _, Just pkg) <- dependenciesPkgInfo ]--    -- The dependencies along with the installed package info, if it exists-    dependenciesPkgInfo :: [(PackageName, InstalledPackageId,-                             Maybe InstalledPackageInfo)]-    dependenciesPkgInfo =-      [ (pkgname, ipkgid, mpkg)-      | (pkgname, ipkgid) <- dependencies-      , let mpkg = PackageIndex.lookupInstalledPackageId-                     installedPackages ipkgid-      ]--    -- If we looked up a package specified by an installed package id-    -- (i.e. someone has written a hash) and didn't find it then it's-    -- an error.-    badInstalledPackageIds =-      [ (pkgname, ipkgid)-      | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]--    -- If someone has written e.g.-    -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have-    -- probably made a mistake.-    badNames =-      [ (requestedPkgName, ipkgid)-      | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo-      , let foundPkgName = packageName pkg-      , requestedPkgName /= foundPkgName ]--    dispDependencies deps =-      hsep [    text "--dependency="-             <> quotes (disp pkgname <> char '=' <> disp ipkgid)-           | (pkgname, ipkgid) <- deps ]---- -------------------------------------------------------------------------------- Configuring hole instantiation--configureInstantiateWith :: PackageDescription-                         -> ConfigFlags-                         -> InstalledPackageIndex -- ^ installed packages-                         -> IO ([InstalledPackageInfo],-                                [(ModuleName, (InstalledPackageInfo, ModuleName))])-configureInstantiateWith pkg_descr cfg installedPackageSet = do-        -- Holes: First, check and make sure the provided instantiation covers-        -- all the holes we know about.  Indefinite package installation is-        -- not handled at all at this point.-        -- NB: We union together /all/ of the requirements when calculating-        -- the package key.-        -- NB: For now, we assume that dependencies don't contribute signatures.-        -- This will be handled by cabal-install; as far as ./Setup is-        -- concerned, the most important thing is to be provided correctly-        -- built dependencies.-        let signatures =-              maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib)-                (PD.library pkg_descr)-            signatureSet = Set.fromList signatures-            instantiateMap = Map.fromList (configInstantiateWith cfg)-            missing_impls = filter (not . flip Map.member instantiateMap) signatures-            hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg)--        when (not (null missing_impls)) $-          die $ "Missing signature implementations for these modules: "-            ++ intercalate ", " (map display missing_impls)--        -- Holes: Next, we need to make sure we have packages to actually-        -- provide the implementations we're talking about.  This is on top-        -- of the normal dependency resolution process.-        -- TODO: internal dependencies (e.g. the test package depending on the-        -- main library) is not currently supported-        let selectHoleDependency (k,(i,m)) =-              case PackageIndex.lookupInstalledPackageId installedPackageSet i of-                Just pkginst -> Right (k,(pkginst, m))-                Nothing -> Left i-            (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0)-            holeDeps = map (fst.snd) hole_insts -- could have dups--        -- Holes: Finally, any dependencies selected this way have to be-        -- included in the allPkgs index, as well as the buildComponents.-        -- But don't report these as potential inconsistencies!--        when (not (null failed_hmap)) $-          die $ "Could not resolve these package IDs (from signature implementations): "-            ++ intercalate ", " (map display failed_hmap)--        return (holeDeps, hole_insts)---- -------------------------------------------------------------------------------- Configuring program dependencies--configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration-                             -> IO ProgramConfiguration-configureRequiredPrograms verbosity deps conf =-  foldM (configureRequiredProgram verbosity) conf deps--configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency-                            -> IO ProgramConfiguration-configureRequiredProgram verbosity conf-  (Dependency (PackageName progName) verRange) =-  case lookupKnownProgram progName conf of-    Nothing -> die ("Unknown build tool " ++ progName)-    Just prog-      -- requireProgramVersion always requires the program have a version-      -- but if the user says "build-depends: foo" ie no version constraint-      -- then we should not fail if we cannot discover the program version.-      | verRange == anyVersion -> do-          (_, conf') <- requireProgram verbosity prog conf-          return conf'-      | otherwise -> do-          (_, _, conf') <- requireProgramVersion verbosity prog verRange conf-          return conf'---- -------------------------------------------------------------------------------- Configuring pkg-config package dependencies--configurePkgconfigPackages :: Verbosity -> PackageDescription-                           -> ProgramConfiguration-                           -> IO (PackageDescription, ProgramConfiguration)-configurePkgconfigPackages verbosity pkg_descr conf-  | null allpkgs = return (pkg_descr, conf)-  | otherwise    = do-    (_, _, conf') <- requireProgramVersion-                       (lessVerbose verbosity) pkgConfigProgram-                       (orLaterVersion $ Version [0,9,0] []) conf-    mapM_ requirePkg allpkgs-    lib' <- mapM addPkgConfigBILib (library pkg_descr)-    exes' <- mapM addPkgConfigBIExe (executables pkg_descr)-    tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)-    benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)-    let pkg_descr' = pkg_descr { library = lib', executables = exes',-                                 testSuites = tests', benchmarks = benches' }-    return (pkg_descr', conf')--  where-    allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr)-    pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity)-                  pkgConfigProgram conf--    requirePkg dep@(Dependency (PackageName pkg) range) = do-      version <- pkgconfig ["--modversion", pkg]-                 `catchIO`   (\_ -> die notFound)-                 `catchExit` (\_ -> die notFound)-      case simpleParse version of-        Nothing -> die "parsing output of pkg-config --modversion failed"-        Just v | not (withinRange v range) -> die (badVersion v)-               | otherwise                 -> info verbosity (depSatisfied v)-      where-        notFound     = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but it could not be found."-        badVersion v = "The pkg-config package '" ++ pkg ++ "'"-                    ++ versionRequirement-                    ++ " is required but the version installed on the"-                    ++ " system is version " ++ display v-        depSatisfied v = "Dependency " ++ display dep-                      ++ ": using version " ++ display v--        versionRequirement-          | isAnyVersion range = ""-          | otherwise          = " version " ++ display range--    -- Adds pkgconfig dependencies to the build info for a component-    addPkgConfigBI compBI setCompBI comp = do-      bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))-      return $ setCompBI comp (compBI comp `mappend` bi)--    -- Adds pkgconfig dependencies to the build info for a library-    addPkgConfigBILib = addPkgConfigBI libBuildInfo $-                          \lib bi -> lib { libBuildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for an executable-    addPkgConfigBIExe = addPkgConfigBI buildInfo $-                          \exe bi -> exe { buildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for a test suite-    addPkgConfigBITest = addPkgConfigBI testBuildInfo $-                          \test bi -> test { testBuildInfo = bi }--    -- Adds pkgconfig dependencies to the build info for a benchmark-    addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $-                          \bench bi -> bench { benchmarkBuildInfo = bi }--    pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo-    pkgconfigBuildInfo []      = return mempty-    pkgconfigBuildInfo pkgdeps = do-      let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ]-      ccflags <- pkgconfig ("--cflags" : pkgs)-      ldflags <- pkgconfig ("--libs"   : pkgs)-      return (ccLdOptionsBuildInfo (words ccflags) (words ldflags))---- | Makes a 'BuildInfo' from C compiler and linker flags.------ This can be used with the output from configuration programs like pkg-config--- and similar package-specific programs like mysql-config, freealut-config etc.--- For example:------ > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"]--- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"]--- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))----ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo-ccLdOptionsBuildInfo cflags ldflags =-  let (includeDirs',  cflags')   = partition ("-I" `isPrefixOf`) cflags-      (extraLibs',    ldflags')  = partition ("-l" `isPrefixOf`) ldflags-      (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'-  in mempty {-       PD.includeDirs  = map (drop 2) includeDirs',-       PD.extraLibs    = map (drop 2) extraLibs',-       PD.extraLibDirs = map (drop 2) extraLibDirs',-       PD.ccOptions    = cflags',-       PD.ldOptions    = ldflags''-     }---- -------------------------------------------------------------------------------- Determining the compiler details--configCompilerAuxEx :: ConfigFlags-                    -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)-                                           (flagToMaybe $ configHcPath cfg)-                                           (flagToMaybe $ configHcPkg cfg)-                                           programsConfig-                                           (fromFlag (configVerbosity cfg))-  where-    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration--configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-                 -> ProgramConfiguration -> Verbosity-                 -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"-configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do-  (comp, maybePlatform, programsConfig) <- case hcFlavor of-    GHC   -> GHC.configure  verbosity hcPath hcPkg conf-    GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf-    JHC   -> JHC.configure  verbosity hcPath hcPkg conf-    LHC   -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf-                LHC.configure  verbosity hcPath Nothing ghcConf-    UHC   -> UHC.configure  verbosity hcPath hcPkg conf-    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf-    _    -> die "Unknown compiler"-  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)---- Ideally we would like to not have separate configCompiler* and--- configCompiler*Ex sets of functions, but there are many custom setup scripts--- in the wild that are using them, so the versions with old types are kept for--- backwards compatibility. Platform was added to the return triple in 1.18.--{-# DEPRECATED configCompiler-    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}-configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-               -> ProgramConfiguration -> Verbosity-               -> IO (Compiler, ProgramConfiguration)-configCompiler mFlavor hcPath hcPkg conf verbosity =-  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity--{-# DEPRECATED configCompilerAux-    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}-configCompilerAux :: ConfigFlags-                  -> IO (Compiler, ProgramConfiguration)-configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx---- -------------------------------------------------------------------------------- Making the internal component graph---mkComponentsGraph :: PackageDescription-                  -> [PackageId]-                  -> Either [ComponentName]-                            [(Component, [ComponentName])]-mkComponentsGraph pkg_descr internalPkgDeps =-    let graph = [ (c, componentName c, componentDeps c)-                | c <- pkgEnabledComponents pkg_descr ]-     in case checkComponentsCyclic graph of-          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]-          Nothing     -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ]-  where-    -- The dependencies for the given component-    componentDeps component =-         [ CExeName toolname | Dependency (PackageName toolname) _-                               <- buildTools bi-                             , toolname `elem` map exeName-                               (executables pkg_descr) ]--      ++ [ CLibName          | Dependency pkgname _ <- targetBuildDepends bi-                             , pkgname `elem` map packageName internalPkgDeps ]-      where-        bi = componentBuildInfo component--reportComponentCycle :: [ComponentName] -> IO a-reportComponentCycle cnames =-    die $ "Components in the package depend on each other in a cyclic way:\n  "-       ++ intercalate " depends on "-            [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ [head cnames] ]--mkComponentsLocalBuildInfo :: Compiler-                           -> InstalledPackageIndex-                           -> PackageDescription-                           -> [PackageId] -- internal package deps-                           -> [InstalledPackageInfo] -- external package deps-                           -> [InstalledPackageInfo] -- hole package deps-                           -> Map ModuleName (InstalledPackageInfo, ModuleName)-                           -> [(Component, [ComponentName])]-                           -> IO [(ComponentName, ComponentLocalBuildInfo,-                                                  [ComponentName])]-mkComponentsLocalBuildInfo comp installedPackages pkg_descr-                           internalPkgDeps externalPkgDeps holePkgDeps hole_insts-                           graph =-    sequence-      [ do clbi <- componentLocalBuildInfo c-           return (componentName c, clbi, cdeps)-      | (c, cdeps) <- graph ]-  where-    -- The allPkgDeps contains all the package deps for the whole package-    -- but we need to select the subset for this specific component.-    -- we just take the subset for the package names this component-    -- needs. Note, this only works because we cannot yet depend on two-    -- versions of the same package.-    componentLocalBuildInfo component =-      case component of-      CLib lib -> do-        let exports = map (\n -> Installed.ExposedModule n Nothing Nothing)-                          (PD.exposedModules lib)-            esigs = map (\n -> Installed.ExposedModule n Nothing-                                (fmap (\(pkg,m) -> Installed.OriginalModule-                                                      (Installed.installedPackageId pkg) m)-                                      (Map.lookup n hole_insts)))-                        (PD.exposedSignatures lib)-        let mb_reexports = resolveModuleReexports installedPackages-                                                  (packageId pkg_descr)-                                                  externalPkgDeps lib-        reexports <- case mb_reexports of-            Left problems -> reportModuleReexportProblems problems-            Right r -> return r--        -- Calculate the version hash and package key.-        let externalPkgs = selectSubset bi externalPkgDeps-            pkg_key = mkPackageKey (packageKeySupported comp)-                        (package pkg_descr)-                        (map Installed.libraryName externalPkgs)-            version_hash = packageKeyLibraryName (package pkg_descr) pkg_key--        return LibComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageKey = pkg_key,-          componentLibraryName = version_hash,-          componentPackageRenaming = cprns,-          componentExposedModules = exports ++ reexports ++ esigs-        }-      CExe _ ->-        return ExeComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      CTest _ ->-        return TestComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      CBench _ ->-        return BenchComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      where-        bi = componentBuildInfo component-        dedup = Map.toList . Map.fromList-        cpds = if newPackageDepsBehaviour pkg_descr-               then dedup $-                    [ (Installed.installedPackageId pkg, packageId pkg)-                    | pkg <- selectSubset bi externalPkgDeps ]-                 ++ [ (inplacePackageId pkgid, pkgid)-                    | pkgid <- selectSubset bi internalPkgDeps ]-               else [ (Installed.installedPackageId pkg, packageId pkg)-                    | pkg <- externalPkgDeps ]-        cprns = if newPackageDepsBehaviour pkg_descr-                then Map.unionWith mappend-                        -- We need hole dependencies passed to GHC, so add them here-                        -- (but note that they're fully thinned out.  If they-                        -- appeared legitimately the monoid instance will-                        -- fill them out.-                        (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps])-                        (targetBuildRenaming bi)-                -- Hack: if we have old package-deps behavior, it's impossible-                -- for non-default renamings to be used, because the Cabal-                -- version is too early.  This is a good, because while all the-                -- deps were bundled up in buildDepends, we didn't do this for-                -- renamings, so it's not even clear how to get the merged-                -- version.  So just assume that all of them are the default..-                else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds)--    selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]-    selectSubset bi pkgs =-        [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ]--    names bi = [ name | Dependency name _ <- targetBuildDepends bi ]---- | Given the author-specified re-export declarations from the .cabal file,--- resolve them to the form that we need for the package database.------ An invariant of the package database is that we always link the re-export--- directly to its original defining location (rather than indirectly via a--- chain of re-exporting packages).----resolveModuleReexports :: InstalledPackageIndex-                       -> PackageId-                       -> [InstalledPackageInfo]-                       -> Library-                       -> Either [(ModuleReexport, String)] -- errors-                                 [Installed.ExposedModule] -- ok-resolveModuleReexports installedPackages srcpkgid externalPkgDeps lib =-    case partitionEithers (map resolveModuleReexport (PD.reexportedModules lib)) of-      ([],  ok) -> Right ok-      (errs, _) -> Left  errs-  where-    -- A mapping from visible module names to their original defining-    -- module name.  We also record the package name of the package which-    -- *immediately* provided the module (not the original) to handle if the-    -- user explicitly says which build-depends they want to reexport from.-    visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)]-    visibleModules =-      Map.fromListWith (++) $-        [ (Installed.exposedName exposedModule, [(exportingPackageName,-                                                  exposedModule)])-          -- The package index here contains all the indirect deps of the-          -- package we're configuring, but we want just the direct deps-        | let directDeps = Set.fromList (map Installed.installedPackageId externalPkgDeps)-        , pkg <- PackageIndex.allPackages installedPackages-        , Installed.installedPackageId pkg `Set.member` directDeps-        , let exportingPackageName = packageName pkg-        , exposedModule <- visibleModuleDetails pkg-        ]-     ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)])-        | visibleModuleName <- PD.exposedModules lib-                            ++ otherModules (libBuildInfo lib)-        , let exportingPackageName = packageName srcpkgid-              definingModuleName   = visibleModuleName-              -- we don't know the InstalledPackageId of this package yet-              -- we will fill it in later, before registration.-              definingPackageId    = InstalledPackageId ""-              originalModule = Installed.OriginalModule definingPackageId-                                                        definingModuleName-              exposedModule  = Installed.ExposedModule visibleModuleName-                                                       (Just originalModule)-                                                             Nothing-        ]--    -- All the modules exported from this package and their defining name and-    -- package (either defined here in this package or re-exported from some-    -- other package).  Return an ExposedModule because we want to hold onto-    -- signature information.-    visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule]-    visibleModuleDetails pkg = do-        exposedModule <- Installed.exposedModules pkg-        case Installed.exposedReexport exposedModule of-        -- The first case is the modules actually defined in this package.-        -- In this case the reexport will point to this package.-            Nothing -> return exposedModule { Installed.exposedReexport =-                            Just (Installed.OriginalModule (Installed.installedPackageId pkg)-                                                 (Installed.exposedName exposedModule)) }-        -- On the other hand, a visible module might actually be itself-        -- a re-export! In this case, the re-export info for the package-        -- doing the re-export will point us to the original defining-        -- module name and package, so we can reuse the entry.-            Just _ -> return exposedModule--    resolveModuleReexport reexport@ModuleReexport {-         moduleReexportOriginalPackage = moriginalPackageName,-         moduleReexportOriginalName    = originalName,-         moduleReexportName            = newName-      } =--      let filterForSpecificPackage =-            case moriginalPackageName of-              Nothing                  -> id-              Just originalPackageName ->-                filter (\(pkgname, _) -> pkgname == originalPackageName)--          matches = filterForSpecificPackage-                      (Map.findWithDefault [] originalName visibleModules)-      in-      case (matches, moriginalPackageName) of-        ((_, exposedModule):rest, _)-          -- TODO: Refine this check for signatures-          | all (\(_, exposedModule') -> Installed.exposedReexport exposedModule-                                      == Installed.exposedReexport exposedModule') rest-           -> Right exposedModule { Installed.exposedName = newName }--        ([], Just originalPackageName)-           -> Left $ (,) reexport-                   $ "The package " ++ display originalPackageName-                  ++ " does not export a module " ++ display originalName--        ([], Nothing)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName-                  ++ " is not exported by any suitable package (this package "-                  ++ "itself nor any of its 'build-depends' dependencies)."--        (ms, _)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName ++ " is exported "-                  ++ "by more than one package ("-                  ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ]-                  ++ ") and so the re-export is ambiguous. The ambiguity can "-                  ++ "be resolved by qualifying by the package name. The "-                  ++ "syntax is 'packagename:moduleName [as newname]'."--        -- Note: if in future Cabal allows directly depending on multiple-        -- instances of the same package (e.g. backpack) then an additional-        -- ambiguity case is possible here: (_, Just originalPackageName)-        -- with the module being ambiguous despite being qualified by a-        -- package name. Presumably by that time we'll have a mechanism to-        -- qualify the instance we're referring to.--reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a-reportModuleReexportProblems reexportProblems =-  die $ unlines-    [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg-    | (reexport, msg) <- reexportProblems ]---- -------------------------------------------------------------------------------- Testing C lib and header dependencies---- Try to build a test C program which includes every header and links every--- lib. If that fails, try to narrow it down by preprocessing (only) and linking--- with individual headers and libs.  If none is the obvious culprit then give a--- generic error message.--- TODO: produce a log file from the compiler errors, if any.-checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()-checkForeignDeps pkg lbi verbosity = do-  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling-                                                               -- lucky-           (return ())-           (do missingLibs <- findMissingLibs-               missingHdr  <- findOffendingHdr-               explainErrors missingHdr missingLibs)-      where-        allHeaders = collectField PD.includes-        allLibs    = collectField PD.extraLibs--        ifBuildsWith headers args success failure = do-            ok <- builds (makeProgram headers) args-            if ok then success else failure--        findOffendingHdr =-            ifBuildsWith allHeaders ccArgs-                         (return Nothing)-                         (go . tail . inits $ allHeaders)-            where-              go [] = return Nothing       -- cannot happen-              go (hdrs:hdrsInits) =-                    -- Try just preprocessing first-                    ifBuildsWith hdrs cppArgs-                      -- If that works, try compiling too-                      (ifBuildsWith hdrs ccArgs-                        (go hdrsInits)-                        (return . Just . Right . last $ hdrs))-                      (return . Just . Left . last $ hdrs)--              cppArgs = "-E":commonCppArgs -- preprocess only-              ccArgs  = "-c":commonCcArgs  -- don't try to link--        findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)-                                       (return [])-                                       (filterM (fmap not . libExists) allLibs)--        libExists lib = builds (makeProgram []) (makeLdArgs [lib])--        commonCppArgs = platformDefines lbi-                     ++ [ "-I" ++ autogenModulesDir lbi ]-                     ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]-                     ++ ["-I."]-                     ++ collectField PD.cppOptions-                     ++ collectField PD.ccOptions-                     ++ [ "-I" ++ dir-                        | dep <- deps-                        , dir <- Installed.includeDirs dep ]-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonCcArgs  = commonCppArgs-                     ++ collectField PD.ccOptions-                     ++ [ opt-                        | dep <- deps-                        , opt <- Installed.ccOptions dep ]--        commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]-                     ++ collectField PD.ldOptions-                     ++ [ "-L" ++ dir-                        | dep <- deps-                        , dir <- Installed.libraryDirs dep ]-                     --TODO: do we also need dependent packages' ld options?-        makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs--        makeProgram hdrs = unlines $-                           [ "#include \""  ++ hdr ++ "\"" | hdr <- hdrs ] ++-                           ["int main(int argc, char** argv) { return 0; }"]--        collectField f = concatMap f allBi-        allBi = allBuildInfo pkg-        deps = PackageIndex.topologicalOrder (installedPkgs lbi)--        builds program args = do-            tempDir <- getTemporaryDirectory-            withTempFile tempDir ".c" $ \cName cHnd ->-              withTempFile tempDir "" $ \oNname oHnd -> do-                hPutStrLn cHnd program-                hClose cHnd-                hClose oHnd-                _ <- rawSystemProgramStdoutConf verbosity-                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)-                return True-           `catchIO`   (\_ -> return False)-           `catchExit` (\_ -> return False)--        explainErrors Nothing [] = return () -- should be impossible!-        explainErrors _ _-           | isNothing . lookupProgram gccProgram . withPrograms $ lbi--                              = die $ unlines $-              [ "No working gcc",-                  "This package depends on foreign library but we cannot "-               ++ "find a working C compiler. If you have it in a "-               ++ "non-standard location you can use the --with-gcc "-               ++ "flag to specify it." ]--        explainErrors hdr libs = die $ unlines $-             [ if plural-                 then "Missing dependencies on foreign libraries:"-                 else "Missing dependency on a foreign library:"-             | missing ]-          ++ case hdr of-               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]-               _             -> []-          ++ case libs of-               []    -> []-               [lib] -> ["* Missing C library: " ++ lib]-               _     -> ["* Missing C libraries: " ++ intercalate ", " libs]-          ++ [if plural then messagePlural else messageSingular | missing]-          ++ case hdr of-               Just (Left  _) -> [ headerCppMessage ]-               Just (Right h) -> [ (if missing then "* " else "")-                                   ++ "Bad header file: " ++ h-                                 , headerCcMessage ]-               _              -> []--          where-            plural  = length libs >= 2-            -- Is there something missing? (as opposed to broken)-            missing = not (null libs)-                   || case hdr of Just (Left _) -> True; _ -> False--        messageSingular =-             "This problem can usually be solved by installing the system "-          ++ "package that provides this library (you may need the "-          ++ "\"-dev\" version). If the library is already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where it is."-        messagePlural =-             "This problem can usually be solved by installing the system "-          ++ "packages that provide these libraries (you may need the "-          ++ "\"-dev\" versions). If the libraries are already installed "-          ++ "but in a non-standard location then you can use the flags "-          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "-          ++ "where they are."-        headerCppMessage =-             "If the header file does exist, it may contain errors that "-          ++ "are caught by the C compiler at the preprocessing stage. "-          ++ "In this case you can re-run configure with the verbosity "-          ++ "flag -v3 to see the error messages."-        headerCcMessage =-             "The header file contains a compile error. "-          ++ "You can re-run configure with the verbosity flag "-          ++ "-v3 to see the error messages from the C compiler."---- | Output package check warnings and errors. Exit if any errors.-checkPackageProblems :: Verbosity-                     -> GenericPackageDescription-                     -> PackageDescription-                     -> IO ()-checkPackageProblems verbosity gpkg pkg = do-  ioChecks      <- checkPackageFiles pkg "."-  let pureChecks = checkPackage gpkg (Just pkg)-      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]-      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]-  if null errors-    then mapM_ (warn verbosity) warnings-    else die (intercalate "\n\n" errors)---- | Preform checks if a relocatable build is allowed-checkRelocatable :: Verbosity-                 -> PackageDescription-                 -> LocalBuildInfo-                 -> IO ()-checkRelocatable verbosity pkg lbi-    = sequence_ [ checkOS-                , checkCompiler-                , packagePrefixRelative-                , depsPrefixRelative-                ]-  where-    -- Check if the OS support relocatable builds.-    ---    -- If you add new OS' to this list, and your OS supports dynamic libraries-    -- and RPATH, make sure you add your OS to RPATH-support list of:-    -- Distribution.Simple.GHC.getRPaths-    checkOS-        = unless (os `elem` [ OSX, Linux ])-        $ die $ "Operating system: " ++ display os ++-                ", does not support relocatable builds"-      where-        (Platform _ os) = hostPlatform lbi--    -- Check if the Compiler support relocatable builds-    checkCompiler-        = unless (compilerFlavor comp `elem` [ GHC ])-        $ die $ "Compiler: " ++ show comp ++-                ", does not support relocatable builds"-      where-        comp = compiler lbi--    -- Check if all the install dirs are relative to same prefix-    packagePrefixRelative-        = unless (relativeInstallDirs installDirs)-        $ die $ "Installation directories are not prefix_relative:\n" ++-                show installDirs-      where-        installDirs = absoluteInstallDirs pkg lbi NoCopyDest-        p           = prefix installDirs-        relativeInstallDirs (InstallDirs {..}) =-          all isJust-              (fmap (stripPrefix p)-                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir-                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )--    -- Check if the library dirs of the dependencies that are in the package-    -- database to which the package is installed are relative to the-    -- prefix of the package-    depsPrefixRelative = do-        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))-        mapM_ (doCheck pkgr) ipkgs-      where-        doCheck pkgr ipkg-          | maybe False (== pkgr) (Installed.pkgRoot ipkg)-          = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))-                  (Installed.libraryDirs ipkg)-          | otherwise-          = return ()+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE NoMonoLocalBinds #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Configure+-- Copyright   :  Isaac Jones 2003-2005+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This deals with the /configure/ phase. It provides the 'configure' action+-- which is given the package description and configure flags. It then tries+-- to: configure the compiler; resolves any conditionals in the package+-- description; resolve the package dependencies; check if all the extensions+-- used by this package are supported by the compiler; check that all the build+-- tools are available (including version checks if appropriate); checks for+-- any required @pkg-config@ packages (updating the 'BuildInfo' with the+-- results)+--+-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes+-- it out to the @dist\/setup-config@ file. It also displays various details to+-- the user, the amount of information displayed depending on the verbosity+-- level.++module Distribution.Simple.Configure (configure,+                                      writePersistBuildConfig,+                                      getConfigStateFile,+                                      getPersistBuildConfig,+                                      checkPersistBuildConfigOutdated,+                                      tryGetPersistBuildConfig,+                                      maybeGetPersistBuildConfig,+                                      findDistPref, findDistPrefOrDefault,+                                      computeComponentId,+                                      computeCompatPackageKey,+                                      computeCompatPackageName,+                                      localBuildInfoFile,+                                      getInstalledPackages,+                                      getInstalledPackagesMonitorFiles,+                                      getPackageDBContents,+                                      configCompiler, configCompilerAux,+                                      configCompilerEx, configCompilerAuxEx,+                                      ccLdOptionsBuildInfo,+                                      checkForeignDeps,+                                      interpretPackageDbFlags,+                                      ConfigStateFileError(..),+                                      tryGetConfigStateFile,+                                      platformDefines,+                                      relaxPackageDeps,+                                     )+    where++import Distribution.Compiler+import Distribution.Utils.NubList+import Distribution.Simple.Compiler hiding (Flag)+import Distribution.Simple.PreProcess+import Distribution.Package+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.InstalledPackageInfo (InstalledPackageInfo+                                         ,emptyInstalledPackageInfo)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.ModuleName+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Check hiding (doesFileExist)+import Distribution.Simple.Program+import Distribution.Simple.Setup as Setup+import qualified Distribution.Simple.InstallDirs as InstallDirs+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Version+import Distribution.Verbosity++import qualified Distribution.Simple.GHC   as GHC+import qualified Distribution.Simple.GHCJS as GHCJS+import qualified Distribution.Simple.JHC   as JHC+import qualified Distribution.Simple.LHC   as LHC+import qualified Distribution.Simple.UHC   as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite++-- Prefer the more generic Data.Traversable.mapM to Prelude.mapM+import Prelude hiding ( mapM )+import Control.Exception+    ( Exception, evaluate, throw, throwIO, try )+import Control.Exception ( ErrorCall )+import Control.Monad+    ( liftM, when, unless, foldM, filterM, mplus )+import Distribution.Compat.Binary ( decodeOrFailIO, encode )+import GHC.Fingerprint ( Fingerprint(..), fingerprintString )+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.List+    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )+import Data.Maybe+    ( isNothing, catMaybes, fromMaybe, mapMaybe, isJust )+import Data.Either+    ( partitionEithers )+import qualified Data.Set as Set+import Data.Monoid as Mon ( Monoid(..) )+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Traversable+    ( mapM )+import Data.Typeable+import Data.Char ( chr, isAlphaNum )+import Numeric ( showIntAtBase )+import System.Directory+    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.FilePath+    ( (</>), isAbsolute )+import qualified System.Info+    ( compilerName, compilerVersion )+import System.IO+    ( hPutStrLn, hClose )+import Distribution.Text+    ( Text(disp), defaultStyle, display, simpleParse )+import Text.PrettyPrint+    ( Doc, (<>), (<+>), ($+$), char, comma, empty, hsep, nest+    , punctuate, quotes, render, renderStyle, sep, text )+import Distribution.Compat.Environment ( lookupEnv )+import Distribution.Compat.Exception ( catchExit, catchIO )++import Data.Graph (graphFromEdges, topSort)++-- | The errors that can be thrown when reading the @setup-config@ file.+data ConfigStateFileError+    = ConfigStateFileNoHeader -- ^ No header found.+    | ConfigStateFileBadHeader -- ^ Incorrect header.+    | ConfigStateFileNoParse -- ^ Cannot parse file contents.+    | ConfigStateFileMissing -- ^ No file!+    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier+      (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.+  deriving (Typeable)++-- | Format a 'ConfigStateFileError' as a user-facing error message.+dispConfigStateFileError :: ConfigStateFileError -> Doc+dispConfigStateFileError ConfigStateFileNoHeader =+    text "Saved package config file header is missing."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileBadHeader =+    text "Saved package config file header is corrupt."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileNoParse =+    text "Saved package config file is corrupt."+    <+> text "Re-run the 'configure' command."+dispConfigStateFileError ConfigStateFileMissing =+    text "Run the 'configure' command first."+dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =+    text "Saved package config file is outdated:"+    $+$ badCabal $+$ badCompiler+    $+$ text "Re-run the 'configure' command."+    where+      badCabal =+          text "• the Cabal version changed from"+          <+> disp oldCabal <+> "to" <+> disp currentCabalId+      badCompiler+        | oldCompiler == currentCompilerId = empty+        | otherwise =+            text "• the compiler changed from"+            <+> disp oldCompiler <+> "to" <+> disp currentCompilerId++instance Show ConfigStateFileError where+    show = renderStyle defaultStyle . dispConfigStateFileError++instance Exception ConfigStateFileError++-- | 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.+getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.+                   -> IO LocalBuildInfo+getConfigStateFile filename = do+    exists <- doesFileExist filename+    unless exists $ throwIO ConfigStateFileMissing+    -- Read the config file into a strict ByteString to avoid problems with+    -- lazy I/O, then convert to lazy because the binary package needs that.+    contents <- BS.readFile filename+    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])++    headerParseResult <- try $ evaluate $ parseHeader header+    let (cabalId, compId) =+            case headerParseResult of+              Left (_ :: ErrorCall) -> throw ConfigStateFileBadHeader+              Right x -> x++    let getStoredValue = do+          result <- decodeOrFailIO (BLC8.tail body)+          case result of+            Left _ -> throw ConfigStateFileNoParse+            Right x -> return x+        deferErrorIfBadVersion act+          | cabalId /= currentCabalId = do+              eResult <- try act+              throw $ ConfigStateFileBadVersion cabalId compId eResult+          | otherwise = act+    deferErrorIfBadVersion getStoredValue++-- | Read the 'localBuildInfoFile', returning either an error or the local build+-- info.+tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.+                      -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetConfigStateFile = try . getConfigStateFile++-- | Try to read the 'localBuildInfoFile'.+tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                         -> IO (Either ConfigStateFileError LocalBuildInfo)+tryGetPersistBuildConfig = try . getPersistBuildConfig++-- | 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 -- ^ The @dist@ directory path.+                      -> IO LocalBuildInfo+getPersistBuildConfig = getConfigStateFile . localBuildInfoFile++-- | Try to read the 'localBuildInfoFile'.+maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                           -> IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig =+    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig++-- | After running configure, output the 'LocalBuildInfo' to the+-- 'localBuildInfoFile'.+writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.+                        -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.+                        -> IO ()+writePersistBuildConfig distPref lbi = do+    createDirectoryIfMissing False distPref+    writeFileAtomic (localBuildInfoFile distPref) $+      BLC8.unlines [showHeader pkgId, encode lbi]+  where+    pkgId = packageId $ localPkgDescr lbi++-- | Identifier of the current Cabal package.+currentCabalId :: PackageIdentifier+currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion++-- | Identifier of the current compiler package.+currentCompilerId :: PackageIdentifier+currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)+                                      System.Info.compilerVersion++-- | Parse the @setup-config@ file header, returning the package identifiers+-- for Cabal and the compiler.+parseHeader :: ByteString -- ^ The file contents.+            -> (PackageIdentifier, PackageIdentifier)+parseHeader header = case BLC8.words header of+  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId,+   "using", compId] ->+      fromMaybe (throw ConfigStateFileBadHeader) $ do+          _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier+          cabalId' <- simpleParse (BLC8.unpack cabalId)+          compId' <- simpleParse (BLC8.unpack compId)+          return (cabalId', compId')+  _ -> throw ConfigStateFileNoHeader++-- | Generate the @setup-config@ file header.+showHeader :: PackageIdentifier -- ^ The processed package.+            -> ByteString+showHeader pkgId = BLC8.unwords+    [ "Saved", "package", "config", "for"+    , BLC8.pack $ display pkgId+    , "written", "by"+    , BLC8.pack $ display currentCabalId+    , "using"+    , BLC8.pack $ display currentCompilerId+    ]++-- | Check that localBuildInfoFile is up-to-date with respect to the+-- .cabal file.+checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool+checkPersistBuildConfigOutdated distPref pkg_descr_file = do+  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)++-- | Get the path of @dist\/setup-config@.+localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.+                    -> FilePath+localBuildInfoFile distPref = distPref </> "setup-config"++-- -----------------------------------------------------------------------------+-- * Configuration+-- -----------------------------------------------------------------------------++-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken+-- from (in order of highest to lowest preference) the override prefix, the+-- \"CABAL_BUILDDIR\" environment variable, or the default prefix.+findDistPref :: FilePath  -- ^ default \"dist\" prefix+             -> Setup.Flag FilePath  -- ^ override \"dist\" prefix+             -> IO FilePath+findDistPref defDistPref overrideDistPref = do+    envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")+    return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)+  where+    parseEnvDistPref env =+      case env of+        Just distPref | not (null distPref) -> toFlag distPref+        _ -> NoFlag++-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken+-- from (in order of highest to lowest preference) the override prefix, the+-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call+-- this function to resolve a @*DistPref@ flag whenever it is not known to be+-- set. (The @*DistPref@ flags are always set to a definite value before+-- invoking 'UserHooks'.)+findDistPrefOrDefault :: Setup.Flag FilePath  -- ^ override \"dist\" prefix+                      -> IO FilePath+findDistPrefOrDefault = findDistPref defaultDistPref++-- |Perform the \"@.\/setup configure@\" action.+-- Returns the @.setup-config@ file.+configure :: (GenericPackageDescription, HookedBuildInfo)+          -> ConfigFlags -> IO LocalBuildInfo+configure (pkg_descr0', pbi) cfg = do+    let pkg_descr0 =+          -- Ignore '--allow-newer' when we're given '--exact-configuration'.+          if fromFlagOrDefault False (configExactConfiguration cfg)+          then pkg_descr0'+          else relaxPackageDeps+               (fromMaybe AllowNewerNone $ configAllowNewer cfg)+               pkg_descr0'++    setupMessage verbosity "Configuring" (packageId pkg_descr0)++    checkDeprecatedFlags verbosity cfg+    checkExactConfiguration pkg_descr0 cfg++    -- Where to build the package+    let buildDir :: FilePath -- e.g. dist/build+        -- fromFlag OK due to Distribution.Simple calling+        -- findDistPrefOrDefault to fill it in+        buildDir = fromFlag (configDistPref cfg) </> "build"+    createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir++    -- What package database(s) to use+    let packageDbs :: PackageDBStack+        packageDbs+         = interpretPackageDbFlags+            (fromFlag (configUserInstall cfg))+            (configPackageDBs cfg)++    -- comp:            the compiler we're building with+    -- compPlatform:    the platform we're building for+    -- programsConfig:  location and args of all programs we're+    --                  building with+    (comp           :: Compiler,+     compPlatform   :: Platform,+     programsConfig :: ProgramConfiguration)+        <- configCompilerEx+            (flagToMaybe (configHcFlavor cfg))+            (flagToMaybe (configHcPath cfg))+            (flagToMaybe (configHcPkg cfg))+            (mkProgramsConfig cfg (configPrograms cfg))+            (lessVerbose verbosity)++    -- The InstalledPackageIndex of all installed packages+    installedPackageSet :: InstalledPackageIndex+        <- getInstalledPackages (lessVerbose verbosity) comp+                                  packageDbs programsConfig++    -- An approximate InstalledPackageIndex of all (possible) internal libraries.+    -- This database is used to bootstrap the process before we know precisely+    -- what these libraries are supposed to be.+    let internalPackageSet :: InstalledPackageIndex+        internalPackageSet = getInternalPackages pkg_descr0++    -- allConstraints:  The set of all 'Dependency's we have.  Used ONLY+    --                  to 'configureFinalizedPackage'.+    -- requiredDepsMap: A map from 'PackageName' to the specifically+    --                  required 'InstalledPackageInfo', due to --dependency+    --+    -- NB: These constraints are to be applied to ALL components of+    -- a package.  Thus, it's not an error if allConstraints contains+    -- more constraints than is necessary for a component (another+    -- component might need it.)+    --+    -- NB: The fact that we bundle all the constraints together means+    -- that is not possible to configure a test-suite to use one+    -- version of a dependency, and the executable to use another.+    (allConstraints  :: [Dependency],+     requiredDepsMap :: Map PackageName InstalledPackageInfo)+        <- either die return $+              combinedConstraints (configConstraints cfg)+                                  (configDependencies cfg)+                                  installedPackageSet++    -- pkg_descr:   The resolved package description, that does not contain any+    --              conditionals, because we have have an assignment for+    --              every flag, either picking them ourselves using a+    --              simple naive algorithm, or having them be passed to+    --              us by 'configConfigurationsFlags')+    -- flags:       The 'FlagAssignment' that the conditionals were+    --              resolved with.+    --+    -- NB: Why doesn't finalizing a package also tell us what the+    -- dependencies are (e.g. when we run the naive algorithm,+    -- we are checking if dependencies are satisfiable)?  The+    -- primary reason is that we may NOT have done any solving:+    -- if the flags are all chosen for us, this step is a simple+    -- matter of flattening according to that assignment.  It's+    -- cleaner to then configure the dependencies afterwards.+    (pkg_descr :: PackageDescription,+     flags     :: FlagAssignment)+        <- configureFinalizedPackage verbosity cfg+                allConstraints+                (dependencySatisfiable+                    (fromFlagOrDefault False (configExactConfiguration cfg))+                    installedPackageSet+                    internalPackageSet+                    requiredDepsMap)+                comp+                compPlatform+                pkg_descr0++    checkCompilerProblems comp pkg_descr+    checkPackageProblems verbosity pkg_descr0+        (updatePackageDescription pbi pkg_descr)++    -- The list of 'InstalledPackageInfo' recording the selected+    -- dependencies...+    -- internalPkgDeps: ...on internal packages (these are fake!)+    -- externalPkgDeps: ...on external packages+    --+    -- Invariant: For any package name, there is at most one package+    -- in externalPackageDeps which has that name.+    --+    -- NB: The dependency selection is global over ALL components+    -- in the package (similar to how allConstraints and+    -- requiredDepsMap are global over all components).  In particular,+    -- if *any* component (post-flag resolution) has an unsatisfiable+    -- dependency, we will fail.  This can sometimes be undesirable+    -- for users, see #1786 (benchmark conflicts with executable),+    (internalPkgDeps :: [PackageId],+     externalPkgDeps :: [InstalledPackageInfo])+        <- configureDependencies+                verbosity+                internalPackageSet+                installedPackageSet+                requiredDepsMap+                pkg_descr++    -- The database of transitively reachable installed packages that the+    -- external components the package (as a whole) depends on.  This will be+    -- used in several ways:+    --+    --      * We'll use it to do a consistency check so we're not depending+    --        on multiple versions of the same package (TODO: someday relax+    --        this for private dependencies.)  See right below.+    --+    --      * We feed it in when configuring the components to resolve+    --        module reexports.  (TODO: axe this.)+    --+    --      * We'll pass it on in the LocalBuildInfo, where preprocessors+    --        and other things will incorrectly use it to determine what+    --        the include paths and everything should be.+    --+    packageDependsIndex :: InstalledPackageIndex <-+      case PackageIndex.dependencyClosure installedPackageSet+              (map Installed.installedUnitId externalPkgDeps) of+        Left packageDependsIndex -> return packageDependsIndex+        Right broken ->+          die $ "The following installed packages are broken because other"+             ++ " packages they depend on are missing. These broken "+             ++ "packages must be rebuilt before they can be used.\n"+             ++ unlines [ "package "+                       ++ display (packageId pkg)+                       ++ " is broken due to missing package "+                       ++ intercalate ", " (map display deps)+                        | (pkg, deps) <- broken ]++    -- In this section, we'd like to look at the 'packageDependsIndex'+    -- and see if we've picked multiple versions of the same+    -- installed package (this is bad, because it means you might+    -- get an error could not match foo-0.1:Type with foo-0.2:Type).+    --+    -- What is pseudoTopPkg for? I have no idea.  It was used+    -- in the very original commit which introduced checking for+    -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,+    -- and then moved out of PackageIndex and put here later.+    -- TODO: Try this code without it...+    --+    -- TODO: Move this into a helper function+    let pseudoTopPkg :: InstalledPackageInfo+        pseudoTopPkg = emptyInstalledPackageInfo {+            Installed.installedUnitId =+               mkLegacyUnitId (packageId pkg_descr),+            Installed.sourcePackageId = packageId pkg_descr,+            Installed.depends =+              map Installed.installedUnitId externalPkgDeps+          }+    case PackageIndex.dependencyInconsistencies+       . PackageIndex.insert pseudoTopPkg+       $ packageDependsIndex of+      [] -> return ()+      inconsistencies ->+        warn verbosity $+             "This package indirectly depends on multiple versions of the same "+          ++ "package. This is highly likely to cause a compile failure.\n"+          ++ unlines [ "package " ++ display pkg ++ " requires "+                    ++ display (PackageIdentifier name ver)+                     | (name, uses) <- inconsistencies+                     , (pkg, ver) <- uses ]++    -- Compute installation directory templates, based on user+    -- configuration.+    --+    -- TODO: Move this into a helper function.+    defaultDirs :: InstallDirTemplates+        <- defaultInstallDirs (compilerFlavor comp)+                              (fromFlag (configUserInstall cfg))+                              (hasLibs pkg_descr)+    let installDirs :: InstallDirTemplates+        installDirs = combineInstallDirs fromFlagOrDefault+                        defaultDirs (configInstallDirs cfg)++    -- Check languages and extensions+    -- TODO: Move this into a helper function.+    let langlist = nub $ catMaybes $ map defaultLanguage+                   (allBuildInfo pkg_descr)+    let langs = unsupportedLanguages comp langlist+    when (not (null langs)) $+      die $ "The package " ++ display (packageId pkg_descr0)+         ++ " requires the following languages which are not "+         ++ "supported by " ++ display (compilerId comp) ++ ": "+         ++ intercalate ", " (map display langs)+    let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr)+    let exts = unsupportedExtensions comp extlist+    when (not (null exts)) $+      die $ "The package " ++ display (packageId pkg_descr0)+         ++ " requires the following language extensions which are not "+         ++ "supported by " ++ display (compilerId comp) ++ ": "+         ++ intercalate ", " (map display exts)++    -- Configure known/required programs & external build tools.+    -- Exclude build-tool deps on "internal" exes in the same package+    --+    -- TODO: Factor this into a helper package.+    let requiredBuildTools =+          [ buildTool+          | let exeNames = map exeName (executables pkg_descr)+          , bi <- allBuildInfo pkg_descr+          , buildTool@(Dependency (PackageName toolName) reqVer)+            <- buildTools bi+          , let isInternal =+                    toolName `elem` exeNames+                    -- we assume all internal build-tools are+                    -- versioned with the package:+                 && packageVersion pkg_descr `withinRange` reqVer+          , not isInternal ]++    programsConfig' <-+          configureAllKnownPrograms (lessVerbose verbosity) programsConfig+      >>= configureRequiredPrograms verbosity requiredBuildTools++    (pkg_descr', programsConfig'') <-+      configurePkgconfigPackages verbosity pkg_descr programsConfig'++    -- Compute internal component graph+    --+    -- The general idea is that we take a look at all the source level+    -- components (which may build-depends on each other) and form a graph.+    -- From there, we build a ComponentLocalBuildInfo for each of the+    -- components, which lets us actually build each component.+    buildComponents <-+      case mkComponentsGraph pkg_descr internalPkgDeps of+        Left  componentCycle -> reportComponentCycle componentCycle+        Right comps          ->+          mkComponentsLocalBuildInfo cfg comp packageDependsIndex pkg_descr+                                     internalPkgDeps externalPkgDeps+                                     comps (configConfigurationsFlags cfg)++    -- Decide if we're going to compile with split objects.+    split_objs :: Bool <-+       if not (fromFlag $ configSplitObjs cfg)+            then return False+            else case compilerFlavor comp of+                        GHC | compilerVersion comp >= Version [6,5] []+                          -> return True+                        GHCJS+                          -> return True+                        _ -> do warn verbosity+                                     ("this compiler does not support " +++                                      "--enable-split-objs; ignoring")+                                return False++    let ghciLibByDefault =+          case compilerId comp of+            CompilerId GHC _ ->+              -- If ghc is non-dynamic, then ghci needs object files,+              -- so we build one by default.+              --+              -- Technically, archive files should be sufficient for ghci,+              -- but because of GHC bug #8942, it has never been safe to+              -- rely on them. By the time that bug was fixed, ghci had+              -- been changed to read shared libraries instead of archive+              -- files (see next code block).+              not (GHC.isDynamic comp)+            CompilerId GHCJS _ ->+              not (GHCJS.isDynamic comp)+            _ -> False++    let sharedLibsByDefault+          | fromFlag (configDynExe cfg) =+              -- build a shared library if dynamically-linked+              -- executables are requested+              True+          | otherwise = case compilerId comp of+            CompilerId GHC _ ->+              -- if ghc is dynamic, then ghci needs a shared+              -- library, so we build one by default.+              GHC.isDynamic comp+            CompilerId GHCJS _ ->+              GHCJS.isDynamic comp+            _ -> False+        withSharedLib_ =+            -- build shared libraries if required by GHC or by the+            -- executable linking mode, but allow the user to force+            -- building only static library archives with+            -- --disable-shared.+            fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg+        withDynExe_ = fromFlag $ configDynExe cfg+    when (withDynExe_ && not withSharedLib_) $ warn verbosity $+           "Executables will use dynamic linking, but a shared library "+        ++ "is not being built. Linking will fail if any executables "+        ++ "depend on the library."++    -- The --profiling flag sets the default for both libs and exes,+    -- but can be overidden by --library-profiling, or the old deprecated+    -- --executable-profiling flag.+    let profEnabledLibOnly = configProfLib cfg+        profEnabledBoth    = fromFlagOrDefault False (configProf cfg)+        profEnabledLib = fromFlagOrDefault profEnabledBoth profEnabledLibOnly+        profEnabledExe = fromFlagOrDefault profEnabledBoth (configProfExe cfg)++    -- The --profiling-detail and --library-profiling-detail flags behave+    -- similarly+    profDetailLibOnly <- checkProfDetail (configProfLibDetail cfg)+    profDetailBoth    <- liftM (fromFlagOrDefault ProfDetailDefault)+                               (checkProfDetail (configProfDetail cfg))+    let profDetailLib = fromFlagOrDefault profDetailBoth profDetailLibOnly+        profDetailExe = profDetailBoth++    when (profEnabledExe && not profEnabledLib) $+      warn verbosity $+           "Executables will be built with profiling, but library "+        ++ "profiling is disabled. Linking will fail if any executables "+        ++ "depend on the library."++    let configCoverage_ =+          mappend (configCoverage cfg) (configLibCoverage cfg)++        cfg' = cfg { configCoverage = configCoverage_ }++    reloc <-+       if not (fromFlag $ configRelocatable cfg)+            then return False+            else return True++    let lbi = LocalBuildInfo {+                configFlags         = cfg',+                flagAssignment      = flags,+                extraConfigArgs     = [],  -- Currently configure does not+                                           -- take extra args, but if it+                                           -- did they would go here.+                installDirTemplates = installDirs,+                compiler            = comp,+                hostPlatform        = compPlatform,+                buildDir            = buildDir,+                componentsConfigs   = buildComponents,+                installedPkgs       = packageDependsIndex,+                pkgDescrFile        = Nothing,+                localPkgDescr       = pkg_descr',+                withPrograms        = programsConfig'',+                withVanillaLib      = fromFlag $ configVanillaLib cfg,+                withProfLib         = profEnabledLib,+                withSharedLib       = withSharedLib_,+                withDynExe          = withDynExe_,+                withProfExe         = profEnabledExe,+                withProfLibDetail   = profDetailLib,+                withProfExeDetail   = profDetailExe,+                withOptimization    = fromFlag $ configOptimization cfg,+                withDebugInfo       = fromFlag $ configDebugInfo cfg,+                withGHCiLib         = fromFlagOrDefault ghciLibByDefault $+                                      configGHCiLib cfg,+                splitObjs           = split_objs,+                stripExes           = fromFlag $ configStripExes cfg,+                stripLibs           = fromFlag $ configStripLibs cfg,+                withPackageDB       = packageDbs,+                progPrefix          = fromFlag $ configProgPrefix cfg,+                progSuffix          = fromFlag $ configProgSuffix cfg,+                relocatable         = reloc+              }++    when reloc (checkRelocatable verbosity pkg_descr lbi)++    -- TODO: This is not entirely correct, because the dirs may vary+    -- across libraries/executables+    let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest+        relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi++    unless (isAbsolute (prefix dirs)) $ die $+        "expected an absolute directory name for --prefix: " ++ prefix dirs++    info verbosity $ "Using " ++ display currentCabalId+                  ++ " compiled by " ++ display currentCompilerId+    info verbosity $ "Using compiler: " ++ showCompilerId comp+    info verbosity $ "Using install prefix: " ++ prefix dirs++    let dirinfo name dir isPrefixRelative =+          info verbosity $ name ++ " installed in: " ++ dir ++ relNote+          where relNote = case buildOS of+                  Windows | not (hasLibs pkg_descr)+                         && isNothing isPrefixRelative+                         -> "  (fixed location)"+                  _      -> ""++    dirinfo "Binaries"         (bindir dirs)     (bindir relative)+    dirinfo "Libraries"        (libdir dirs)     (libdir relative)+    dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)+    dirinfo "Data files"       (datadir dirs)    (datadir relative)+    dirinfo "Documentation"    (docdir dirs)     (docdir relative)+    dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)++    sequence_ [ reportProgram verbosity prog configuredProg+              | (prog, configuredProg) <- knownPrograms programsConfig'' ]++    return lbi++    where+      verbosity = fromFlag (configVerbosity cfg)++      checkProfDetail (Flag (ProfDetailOther other)) = do+        warn verbosity $+             "Unknown profiling detail level '" ++ other+          ++ "', using default.\n"+          ++ "The profiling detail levels are: " ++ intercalate ", "+             [ name | (name, _, _) <- knownProfDetailLevels ]+        return (Flag ProfDetailDefault)+      checkProfDetail other = return other++mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration+mkProgramsConfig cfg initialProgramsConfig = programsConfig+  where+    programsConfig = userSpecifyArgss (configProgramArgs cfg)+                   . userSpecifyPaths (configProgramPaths cfg)+                   . setProgramSearchPath searchpath+                   $ initialProgramsConfig+    searchpath     = getProgramSearchPath (initialProgramsConfig)+                  ++ map ProgramSearchPathDir+                     (fromNubList $ configProgramPathExtra cfg)++-- -----------------------------------------------------------------------------+-- Helper functions for configure++-- | Check if the user used any deprecated flags.+checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO ()+checkDeprecatedFlags verbosity cfg = do+    unless (configProfExe cfg == NoFlag) $ do+      let enable | fromFlag (configProfExe cfg) = "enable"+                 | otherwise = "disable"+      warn verbosity+        ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "+         ++ "Please use --" ++ enable ++ "-profiling instead.")++    unless (configLibCoverage cfg == NoFlag) $ do+      let enable | fromFlag (configLibCoverage cfg) = "enable"+                 | otherwise = "disable"+      warn verbosity+        ("The flag --" ++ enable ++ "-library-coverage is deprecated. "+         ++ "Please use --" ++ enable ++ "-coverage instead.")++-- | Sanity check: if '--exact-configuration' was given, ensure that the+-- complete flag assignment was specified on the command line.+checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO ()+checkExactConfiguration pkg_descr0 cfg = do+    when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do+      let cmdlineFlags = map fst (configConfigurationsFlags cfg)+          allFlags     = map flagName . genPackageFlags $ pkg_descr0+          diffFlags    = allFlags \\ cmdlineFlags+      when (not . null $ diffFlags) $+        die $ "'--exact-configuration' was given, "+        ++ "but the following flags were not specified: "+        ++ intercalate ", " (map show diffFlags)++-- | Create a PackageIndex that makes *any libraries that might be*+-- defined internally to this package look like installed packages, in+-- case an executable should refer to any of them as dependencies.+--+-- It must be *any libraries that might be* defined rather than the+-- actual definitions, because these depend on conditionals in the .cabal+-- file, and we haven't resolved them yet.  finalizePackageDescription+-- does the resolution of conditionals, and it takes internalPackageSet+-- as part of its input.+getInternalPackages :: GenericPackageDescription+                    -> InstalledPackageIndex+getInternalPackages pkg_descr0 =+    let pkg_descr = flattenPackageDescription pkg_descr0+        mkInternalPackage lib = emptyInstalledPackageInfo {+            --TODO: should use a per-compiler method to map the source+            --      package ID into an installed package id we can use+            --      for the internal package set.  What we do here+            --      is skeevy, but we're highly unlikely to accidentally+            --      shadow something legitimate.+            Installed.installedUnitId = mkUnitId (libName lib),+            -- NB: we TEMPORARILY set the package name to be the+            -- library name.  When we actually register, it won't+            -- look like this; this is just so that internal+            -- build-depends get resolved correctly.+            Installed.sourcePackageId = PackageIdentifier (PackageName (libName lib))+                                            (pkgVersion (package pkg_descr))+          }+    in PackageIndex.fromList (map mkInternalPackage (libraries pkg_descr))+++-- | Returns true if a dependency is satisfiable.  This is to be passed+-- to finalizePackageDescription.+dependencySatisfiable+    :: Bool+    -> InstalledPackageIndex -- ^ installed set+    -> InstalledPackageIndex -- ^ internal set+    -> Map PackageName InstalledPackageInfo -- ^ required dependencies+    -> (Dependency -> Bool)+dependencySatisfiable+    exact_config installedPackageSet internalPackageSet requiredDepsMap+    d@(Dependency depName _)+      | exact_config =+        -- When we're given '--exact-configuration', we assume that all+        -- dependencies and flags are exactly specified on the command+        -- line. Thus we only consult the 'requiredDepsMap'. Note that+        -- we're not doing the version range check, so if there's some+        -- dependency that wasn't specified on the command line,+        -- 'finalizePackageDescription' will fail.+        --+        -- TODO: mention '--exact-configuration' in the error message+        -- when this fails?+        --+        -- (However, note that internal deps don't have to be+        -- specified!)+        (depName `Map.member` requiredDepsMap) || isInternalDep++      | otherwise =+        -- Normal operation: just look up dependency in the combined+        -- package index.+        not . null . PackageIndex.lookupDependency pkgs $ d+      where+        -- NB: Prefer the INTERNAL package set+        pkgs = PackageIndex.merge installedPackageSet internalPackageSet+        isInternalDep = not . null+                      $ PackageIndex.lookupDependency internalPackageSet d++-- | Relax the dependencies of this package if needed.+relaxPackageDeps :: AllowNewer -> GenericPackageDescription+                 -> GenericPackageDescription+relaxPackageDeps AllowNewerNone gpd = gpd+relaxPackageDeps AllowNewerAll  gpd = transformAllBuildDepends relaxAll gpd+  where+    relaxAll = \(Dependency pkgName verRange) ->+      Dependency pkgName (removeUpperBound verRange)+relaxPackageDeps (AllowNewerSome allowNewerDeps') gpd =+  transformAllBuildDepends relaxSome gpd+  where+    thisPkgName    = packageName gpd+    allowNewerDeps = mapMaybe f allowNewerDeps'++    f (Setup.AllowNewerDep p) = Just p+    f (Setup.AllowNewerDepScoped scope p) | scope == thisPkgName = Just p+                                          | otherwise            = Nothing++    relaxSome = \d@(Dependency depName verRange) ->+      if depName `elem` allowNewerDeps+      then Dependency depName (removeUpperBound verRange)+      else d++-- | Finalize a generic package description.  The workhorse is+-- 'finalizePackageDescription' but there's a bit of other nattering+-- about necessary.+--+-- TODO: what exactly is the business with @flaggedTests@ and+-- @flaggedBenchmarks@?+configureFinalizedPackage+    :: Verbosity+    -> ConfigFlags+    -> [Dependency]+    -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable.+                            -- Might say it's satisfiable even when not.+    -> Compiler+    -> Platform+    -> GenericPackageDescription+    -> IO (PackageDescription, FlagAssignment)+configureFinalizedPackage verbosity cfg+  allConstraints satisfies comp compPlatform pkg_descr0 = do+    let enableTest t = t { testEnabled = fromFlag (configTests cfg) }+        flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))+                           (condTestSuites pkg_descr0)+        enableBenchmark bm = bm { benchmarkEnabled =+                                     fromFlag (configBenchmarks cfg) }+        flaggedBenchmarks = map (\(n, bm) ->+                                  (n, mapTreeData enableBenchmark bm))+                           (condBenchmarks pkg_descr0)+        pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests+                                  , condBenchmarks = flaggedBenchmarks }++    (pkg_descr0', flags) <-+            case finalizePackageDescription+                   (configConfigurationsFlags cfg)+                   satisfies+                   compPlatform+                   (compilerInfo comp)+                   allConstraints+                   pkg_descr0''+            of Right r -> return r+               Left missing ->+                   die $ "Encountered missing dependencies:\n"+                     ++ (render . nest 4 . sep . punctuate comma+                                . map (disp . simplifyDependency)+                                $ missing)++    -- add extra include/lib dirs as specified in cfg+    -- we do it here so that those get checked too+    let pkg_descr = addExtraIncludeLibDirs pkg_descr0'++    when (not (null flags)) $+      info verbosity $ "Flags chosen: "+                    ++ intercalate ", " [ name ++ "=" ++ display value+                                        | (FlagName name, value) <- flags ]++    return (pkg_descr, flags)+  where+    addExtraIncludeLibDirs pkg_descr =+        let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg+                             , extraFrameworkDirs = configExtraFrameworkDirs cfg+                             , PD.includeDirs = configExtraIncludeDirs cfg}+            modifyLib l        = l{ libBuildInfo = libBuildInfo l+                                                   `mappend` extraBi }+            modifyExecutable e = e{ buildInfo    = buildInfo e+                                                   `mappend` extraBi}+        in pkg_descr{ libraries   = modifyLib         `map` libraries pkg_descr+                    , executables = modifyExecutable  `map`+                                      executables pkg_descr}++-- | Check for use of Cabal features which require compiler support+checkCompilerProblems :: Compiler -> PackageDescription -> IO ()+checkCompilerProblems comp pkg_descr = do+    unless (renamingPackageFlagsSupported comp ||+                and [ True+                    | bi <- allBuildInfo pkg_descr+                    , _ <- Map.elems (targetBuildRenaming bi)]) $+        die $ "Your compiler does not support thinning and renaming on "+           ++ "package flags.  To use this feature you probably must use "+           ++ "GHC 7.9 or later."++    when (any (not.null.PD.reexportedModules) (PD.libraries pkg_descr)+          && not (reexportedModulesSupported comp)) $ do+        die $ "Your compiler does not support module re-exports. To use "+           ++ "this feature you probably must use GHC 7.9 or later."++-- | Select dependencies for the package.+configureDependencies+    :: Verbosity+    -> InstalledPackageIndex -- ^ internal packages+    -> InstalledPackageIndex -- ^ installed packages+    -> Map PackageName InstalledPackageInfo -- ^ required deps+    -> PackageDescription+    -> IO ([PackageId], [InstalledPackageInfo])+configureDependencies verbosity+  internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do+    let selectDependencies :: [Dependency] ->+                              ([FailedDependency], [ResolvedDependency])+        selectDependencies =+            partitionEithers+          . map (selectDependency internalPackageSet installedPackageSet+                                  requiredDepsMap)++        (failedDeps, allPkgDeps) =+          selectDependencies (buildDepends pkg_descr)++        internalPkgDeps = [ pkgid+                          | InternalDependency _ pkgid <- allPkgDeps ]+        externalPkgDeps = [ pkg+                          | ExternalDependency _ pkg   <- allPkgDeps ]++    when (not (null internalPkgDeps)+          && not (newPackageDepsBehaviour pkg_descr)) $+        die $ "The field 'build-depends: "+           ++ intercalate ", " (map (display . packageName) internalPkgDeps)+           ++ "' refers to a library which is defined within the same "+           ++ "package. To use this feature the package must specify at "+           ++ "least 'cabal-version: >= 1.8'."++    reportFailedDependencies failedDeps+    reportSelectedDependencies verbosity allPkgDeps++    return (internalPkgDeps, externalPkgDeps)++-- -----------------------------------------------------------------------------+-- Configuring package dependencies++reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO ()+reportProgram verbosity prog Nothing+    = info verbosity $ "No " ++ programName prog ++ " found"+reportProgram verbosity prog (Just configuredProg)+    = info verbosity $ "Using " ++ programName prog ++ version ++ location+    where location = case programLocation configuredProg of+            FoundOnSystem p -> " found on system at: " ++ p+            UserSpecified p -> " given by user at: " ++ p+          version = case programVersion configuredProg of+            Nothing -> ""+            Just v  -> " version " ++ display v++hackageUrl :: String+hackageUrl = "http://hackage.haskell.org/package/"++data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo+                        | InternalDependency Dependency PackageId -- should be a+                                                                      -- lib name++data FailedDependency = DependencyNotExists PackageName+                      | DependencyNoVersion Dependency++-- | Test for a package dependency and record the version we have installed.+selectDependency :: InstalledPackageIndex  -- ^ Internally defined packages+                 -> InstalledPackageIndex  -- ^ Installed packages+                 -> Map PackageName InstalledPackageInfo+                    -- ^ Packages for which we have been given specific deps to+                    -- use+                 -> Dependency+                 -> Either FailedDependency ResolvedDependency+selectDependency internalIndex installedIndex requiredDepsMap+  dep@(Dependency pkgname vr) =+  -- If the dependency specification matches anything in the internal package+  -- index, then we prefer that match to anything in the second.+  -- For example:+  --+  -- Name: MyLibrary+  -- Version: 0.1+  -- Library+  --     ..+  -- Executable my-exec+  --     build-depends: MyLibrary+  --+  -- We want "build-depends: MyLibrary" always to match the internal library+  -- even if there is a newer installed library "MyLibrary-0.2".+  -- However, "build-depends: MyLibrary >= 0.2" should match the installed one.+  case PackageIndex.lookupPackageName internalIndex pkgname of+    [(_,[pkg])] | packageVersion pkg `withinRange` vr+           -> Right $ InternalDependency dep (packageId pkg)++    _      -> case Map.lookup pkgname requiredDepsMap of+      -- If we know the exact pkg to use, then use it.+      Just pkginstance -> Right (ExternalDependency dep pkginstance)+      -- Otherwise we just pick an arbitrary instance of the latest version.+      Nothing -> case PackageIndex.lookupDependency installedIndex dep of+        []   -> Left  $ DependencyNotExists pkgname+        pkgs -> Right $ ExternalDependency dep $+                case last pkgs of+                  (_ver, pkginstances) -> head pkginstances++reportSelectedDependencies :: Verbosity+                           -> [ResolvedDependency] -> IO ()+reportSelectedDependencies verbosity deps =+  info verbosity $ unlines+    [ "Dependency " ++ display (simplifyDependency dep)+                    ++ ": using " ++ display pkgid+    | resolved <- deps+    , let (dep, pkgid) = case resolved of+            ExternalDependency dep' pkg'   -> (dep', packageId pkg')+            InternalDependency dep' pkgid' -> (dep', pkgid') ]++reportFailedDependencies :: [FailedDependency] -> IO ()+reportFailedDependencies []     = return ()+reportFailedDependencies failed =+    die (intercalate "\n\n" (map reportFailedDependency failed))++  where+    reportFailedDependency (DependencyNotExists pkgname) =+         "there is no version of " ++ display pkgname ++ " installed.\n"+      ++ "Perhaps you need to download and install it from\n"+      ++ hackageUrl ++ display pkgname ++ "?"++    reportFailedDependency (DependencyNoVersion dep) =+        "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n"++-- | List all installed packages in the given package databases.+getInstalledPackages :: Verbosity -> Compiler+                     -> PackageDBStack -- ^ The stack of package databases.+                     -> ProgramConfiguration+                     -> IO InstalledPackageIndex+getInstalledPackages verbosity comp packageDBs progconf = do+  when (null packageDBs) $+    die $ "No package databases have been specified. If you use "+       ++ "--package-db=clear, you must follow it with --package-db= "+       ++ "with 'global', 'user' or a specific file."++  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC   -> GHC.getInstalledPackages verbosity comp packageDBs progconf+    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf+    JHC   -> JHC.getInstalledPackages verbosity packageDBs progconf+    LHC   -> LHC.getInstalledPackages verbosity packageDBs progconf+    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progconf+    HaskellSuite {} ->+      HaskellSuite.getInstalledPackages verbosity packageDBs progconf+    flv -> die $ "don't know how to find the installed packages for "+              ++ display flv++-- | Like 'getInstalledPackages', but for a single package DB.+--+-- NB: Why isn't this always a fall through to 'getInstalledPackages'?+-- That is because 'getInstalledPackages' performs some sanity checks+-- on the package database stack in question.  However, when sandboxes+-- are involved these sanity checks are not desirable.+getPackageDBContents :: Verbosity -> Compiler+                     -> PackageDB -> ProgramConfiguration+                     -> IO InstalledPackageIndex+getPackageDBContents verbosity comp packageDB progconf = do+  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC -> GHC.getPackageDBContents verbosity packageDB progconf+    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf+    -- For other compilers, try to fall back on 'getInstalledPackages'.+    _   -> getInstalledPackages verbosity comp [packageDB] progconf+++-- | A set of files (or directories) that can be monitored to detect when+-- there might have been a change in the installed packages.+--+getInstalledPackagesMonitorFiles :: Verbosity -> Compiler+                                 -> PackageDBStack+                                 -> ProgramConfiguration -> Platform+                                 -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity comp packageDBs progconf platform =+  case compilerFlavor comp of+    GHC   -> GHC.getInstalledPackagesMonitorFiles+               verbosity platform progconf packageDBs+    other -> do+      warn verbosity $ "don't know how to find change monitoring files for "+                    ++ "the installed package databases for " ++ display other+      return []++-- | The user interface specifies the package dbs to use with a combination of+-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.+-- This function combines the global/user flag and interprets the package-db+-- flag into a single package db stack.+--+interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack+interpretPackageDbFlags userInstall specificDBs =+    extra initialStack specificDBs+  where+    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]+                 | otherwise   = [GlobalPackageDB]++    extra dbs' []            = dbs'+    extra _    (Nothing:dbs) = extra []             dbs+    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs++newPackageDepsBehaviourMinVersion :: Version+newPackageDepsBehaviourMinVersion = Version [1,7,1] []++-- In older cabal versions, there was only one set of package dependencies for+-- the whole package. In this version, we can have separate dependencies per+-- target, but we only enable this behaviour if the minimum cabal version+-- specified is >= a certain minimum. Otherwise, for compatibility we use the+-- old behaviour.+newPackageDepsBehaviour :: PackageDescription -> Bool+newPackageDepsBehaviour pkg =+   specVersion pkg >= newPackageDepsBehaviourMinVersion++-- We are given both --constraint="foo < 2.0" style constraints and also+-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".+--+-- When finalising the package we have to take into account the specific+-- installed deps we've been given, and the finalise function expects+-- constraints, so we have to translate these deps into version constraints.+--+-- But after finalising we then have to make sure we pick the right specific+-- deps in the end. So we still need to remember which installed packages to+-- pick.+combinedConstraints :: [Dependency] ->+                       [(PackageName, UnitId)] ->+                       InstalledPackageIndex ->+                       Either String ([Dependency],+                                      Map PackageName InstalledPackageInfo)+combinedConstraints constraints dependencies installedPackages = do++    when (not (null badUnitIds)) $+      Left $ render $ text "The following package dependencies were requested"+         $+$ nest 4 (dispDependencies badUnitIds)+         $+$ text "however the given installed package instance does not exist."++    when (not (null badNames)) $+      Left $ render $ text "The following package dependencies were requested"+         $+$ nest 4 (dispDependencies badNames)+         $+$ text ("however the installed package's name does not match "+                   ++ "the name given.")++    --TODO: we don't check that all dependencies are used!++    return (allConstraints, idConstraintMap)++  where+    allConstraints :: [Dependency]+    allConstraints = constraints+                  ++ [ thisPackageVersion (packageId pkg)+                     | (_, _, Just pkg) <- dependenciesPkgInfo ]++    idConstraintMap :: Map PackageName InstalledPackageInfo+    idConstraintMap = Map.fromList+                        [ (packageName pkg, pkg)+                        | (_, _, Just pkg) <- dependenciesPkgInfo ]++    -- The dependencies along with the installed package info, if it exists+    dependenciesPkgInfo :: [(PackageName, UnitId,+                             Maybe InstalledPackageInfo)]+    dependenciesPkgInfo =+      [ (pkgname, ipkgid, mpkg)+      | (pkgname, ipkgid) <- dependencies+      , let mpkg = PackageIndex.lookupUnitId+                     installedPackages ipkgid+      ]++    -- If we looked up a package specified by an installed package id+    -- (i.e. someone has written a hash) and didn't find it then it's+    -- an error.+    badUnitIds =+      [ (pkgname, ipkgid)+      | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]++    -- If someone has written e.g.+    -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have+    -- probably made a mistake.+    badNames =+      [ (requestedPkgName, ipkgid)+      | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo+      , let foundPkgName = packageName pkg+      , requestedPkgName /= foundPkgName ]++    dispDependencies deps =+      hsep [    text "--dependency="+             <> quotes (disp pkgname <> char '=' <> disp ipkgid)+           | (pkgname, ipkgid) <- deps ]++-- -----------------------------------------------------------------------------+-- Configuring program dependencies++configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration+                             -> IO ProgramConfiguration+configureRequiredPrograms verbosity deps conf =+  foldM (configureRequiredProgram verbosity) conf deps++configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency+                            -> IO ProgramConfiguration+configureRequiredProgram verbosity conf+  (Dependency (PackageName progName) verRange) =+  case lookupKnownProgram progName conf of+    Nothing -> die ("Unknown build tool " ++ progName)+    Just prog+      -- requireProgramVersion always requires the program have a version+      -- but if the user says "build-depends: foo" ie no version constraint+      -- then we should not fail if we cannot discover the program version.+      | verRange == anyVersion -> do+          (_, conf') <- requireProgram verbosity prog conf+          return conf'+      | otherwise -> do+          (_, _, conf') <- requireProgramVersion verbosity prog verRange conf+          return conf'++-- -----------------------------------------------------------------------------+-- Configuring pkg-config package dependencies++configurePkgconfigPackages :: Verbosity -> PackageDescription+                           -> ProgramConfiguration+                           -> IO (PackageDescription, ProgramConfiguration)+configurePkgconfigPackages verbosity pkg_descr conf+  | null allpkgs = return (pkg_descr, conf)+  | otherwise    = do+    (_, _, conf') <- requireProgramVersion+                       (lessVerbose verbosity) pkgConfigProgram+                       (orLaterVersion $ Version [0,9,0] []) conf+    mapM_ requirePkg allpkgs+    libs' <- mapM addPkgConfigBILib (libraries pkg_descr)+    exes' <- mapM addPkgConfigBIExe (executables pkg_descr)+    tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)+    benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)+    let pkg_descr' = pkg_descr { libraries = libs', executables = exes',+                                 testSuites = tests', benchmarks = benches' }+    return (pkg_descr', conf')++  where+    allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr)+    pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity)+                  pkgConfigProgram conf++    requirePkg dep@(Dependency (PackageName pkg) range) = do+      version <- pkgconfig ["--modversion", pkg]+                 `catchIO`   (\_ -> die notFound)+                 `catchExit` (\_ -> die notFound)+      case simpleParse version of+        Nothing -> die "parsing output of pkg-config --modversion failed"+        Just v | not (withinRange v range) -> die (badVersion v)+               | otherwise                 -> info verbosity (depSatisfied v)+      where+        notFound     = "The pkg-config package '" ++ pkg ++ "'"+                    ++ versionRequirement+                    ++ " is required but it could not be found."+        badVersion v = "The pkg-config package '" ++ pkg ++ "'"+                    ++ versionRequirement+                    ++ " is required but the version installed on the"+                    ++ " system is version " ++ display v+        depSatisfied v = "Dependency " ++ display dep+                      ++ ": using version " ++ display v++        versionRequirement+          | isAnyVersion range = ""+          | otherwise          = " version " ++ display range++    -- Adds pkgconfig dependencies to the build info for a component+    addPkgConfigBI compBI setCompBI comp = do+      bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp))+      return $ setCompBI comp (compBI comp `mappend` bi)++    -- Adds pkgconfig dependencies to the build info for a library+    addPkgConfigBILib = addPkgConfigBI libBuildInfo $+                          \lib bi -> lib { libBuildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for an executable+    addPkgConfigBIExe = addPkgConfigBI buildInfo $+                          \exe bi -> exe { buildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for a test suite+    addPkgConfigBITest = addPkgConfigBI testBuildInfo $+                          \test bi -> test { testBuildInfo = bi }++    -- Adds pkgconfig dependencies to the build info for a benchmark+    addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $+                          \bench bi -> bench { benchmarkBuildInfo = bi }++    pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo+    pkgconfigBuildInfo []      = return Mon.mempty+    pkgconfigBuildInfo pkgdeps = do+      let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ]+      ccflags <- pkgconfig ("--cflags" : pkgs)+      ldflags <- pkgconfig ("--libs"   : pkgs)+      return (ccLdOptionsBuildInfo (words ccflags) (words ldflags))++-- | Makes a 'BuildInfo' from C compiler and linker flags.+--+-- This can be used with the output from configuration programs like pkg-config+-- and similar package-specific programs like mysql-config, freealut-config etc.+-- For example:+--+-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"]+-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"]+-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags))+--+ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo+ccLdOptionsBuildInfo cflags ldflags =+  let (includeDirs',  cflags')   = partition ("-I" `isPrefixOf`) cflags+      (extraLibs',    ldflags')  = partition ("-l" `isPrefixOf`) ldflags+      (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'+  in mempty {+       PD.includeDirs  = map (drop 2) includeDirs',+       PD.extraLibs    = map (drop 2) extraLibs',+       PD.extraLibDirs = map (drop 2) extraLibDirs',+       PD.ccOptions    = cflags',+       PD.ldOptions    = ldflags''+     }++-- -----------------------------------------------------------------------------+-- Determining the compiler details++configCompilerAuxEx :: ConfigFlags+                    -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)+                                           (flagToMaybe $ configHcPath cfg)+                                           (flagToMaybe $ configHcPkg cfg)+                                           programsConfig+                                           (fromFlag (configVerbosity cfg))+  where+    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration++configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+                 -> ProgramConfiguration -> Verbosity+                 -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"+configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do+  (comp, maybePlatform, programsConfig) <- case hcFlavor of+    GHC   -> GHC.configure  verbosity hcPath hcPkg conf+    GHCJS -> GHCJS.configure verbosity hcPath hcPkg conf+    JHC   -> JHC.configure  verbosity hcPath hcPkg conf+    LHC   -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf+                LHC.configure  verbosity hcPath Nothing ghcConf+    UHC   -> UHC.configure  verbosity hcPath hcPkg conf+    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf+    _    -> die "Unknown compiler"+  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)++-- Ideally we would like to not have separate configCompiler* and+-- configCompiler*Ex sets of functions, but there are many custom setup scripts+-- in the wild that are using them, so the versions with old types are kept for+-- backwards compatibility. Platform was added to the return triple in 1.18.++{-# DEPRECATED configCompiler+    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}+configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+               -> ProgramConfiguration -> Verbosity+               -> IO (Compiler, ProgramConfiguration)+configCompiler mFlavor hcPath hcPkg conf verbosity =+  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity++{-# DEPRECATED configCompilerAux+    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}+configCompilerAux :: ConfigFlags+                  -> IO (Compiler, ProgramConfiguration)+configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx++-- -----------------------------------------------------------------------------+-- Making the internal component graph++-- | Given the package description and the set of package names which+-- are considered internal (the current package name and any internal+-- libraries are considered internal), create a graph of dependencies+-- between the components.  This is NOT necessarily the build order+-- (although it is in the absence of Backpack.)+--+-- TODO: tighten up the type of 'internalPkgDeps'+mkComponentsGraph :: PackageDescription+                  -> [PackageId]+                  -> Either [ComponentName]+                            [(Component, [ComponentName])]+mkComponentsGraph pkg_descr internalPkgDeps =+    let graph = [ (c, componentName c, componentDeps c)+                | c <- pkgEnabledComponents pkg_descr ]+     in case checkComponentsCyclic graph of+          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]+          Nothing     -> Right [ (c, cdeps) | (c, _, cdeps) <- topSortFromEdges graph ]+  where+    -- The dependencies for the given component+    componentDeps component =+         [ CExeName toolname | Dependency (PackageName toolname) _+                               <- buildTools bi+                             , toolname `elem` map exeName+                               (executables pkg_descr) ]++      ++ [ CLibName toolname | Dependency pkgname@(PackageName toolname) _+                               <- targetBuildDepends bi+                             , pkgname `elem` map packageName internalPkgDeps ]+      where+        bi = componentBuildInfo component++reportComponentCycle :: [ComponentName] -> IO a+reportComponentCycle cnames =+    die $ "Components in the package depend on each other in a cyclic way:\n  "+       ++ intercalate " depends on "+            [ "'" ++ showComponentName cname ++ "'"+            | cname <- cnames ++ [head cnames] ]++-- | This method computes a default, "good enough" 'ComponentId'+-- for a package.  The intent is that cabal-install (or the user) will+-- specify a more detailed IPID via the @--ipid@ flag if necessary.+computeComponentId+    :: Flag String+    -> PackageIdentifier+    -> ComponentName+    -- TODO: careful here!+    -> [ComponentId] -- IPIDs of the component dependencies+    -> FlagAssignment+    -> ComponentId+computeComponentId mb_explicit pid cname dep_ipids flagAssignment = do+    -- show is found to be faster than intercalate and then replacement of+    -- special character used in intercalating. We cannot simply hash by+    -- doubly concating list, as it just flatten out the nested list, so+    -- different sources can produce same hash+    let hash = hashToBase62 $+                -- For safety, include the package + version here+                -- for GHC 7.10, where just the hash is used as+                -- the package key+                         display pid+                      ++ show dep_ipids+                      ++ show flagAssignment+        generated_base = display pid ++ "-" ++ hash+        explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env+                                                    (toPathTemplate cid0))+            -- Hack to reuse install dirs machinery+            -- NB: no real IPID available at this point+          where env = packageTemplateEnv pid (mkUnitId "")+        actual_base = case mb_explicit of+                        Flag cid0 -> explicit_base cid0+                        NoFlag -> generated_base+    ComponentId $ actual_base+                    ++ (case componentNameString (pkgName pid) cname of+                            Nothing -> ""+                            Just s -> "-" ++ s)++hashToBase62 :: String -> String+hashToBase62 s = showFingerprint $ fingerprintString s+  where+    showIntAtBase62 x = showIntAtBase 62 representBase62 x ""+    representBase62 x+        | x < 10 = chr (48 + x)+        | x < 36 = chr (65 + x - 10)+        | x < 62 = chr (97 + x - 36)+        | otherwise = '@'+    showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b++-- | Computes the package name for a library.  If this is the public+-- library, it will just be the original package name; otherwise,+-- it will be a munged package name recording the original package+-- name as well as the name of the internal library.+--+-- A lot of tooling in the Haskell ecosystem assumes that if something+-- is installed to the package database with the package name 'foo',+-- then it actually is an entry for the (only public) library in package+-- 'foo'.  With internal packages, this is not necessarily true:+-- a public library as well as arbitrarily many internal libraries may+-- come from the same package.  To prevent tools from getting confused+-- in this case, the package name of these internal libraries is munged+-- so that they do not conflict the public library proper.+--+-- We munge into a reserved namespace, "z-", and encode both the+-- component name and the package name of an internal library using the+-- following format:+--+--      compat-pkg-name ::= "z-" package-name "-z-" library-name+--+-- where package-name and library-name have "-" ( "z" + ) "-"+-- segments encoded by adding an extra "z".+--+-- When we have the public library, the compat-pkg-name is just the+-- package-name, no surprises there!+--+computeCompatPackageName :: PackageName -> ComponentName -> PackageName+computeCompatPackageName pkg_name cname+    | Just cname_str <- componentNameString pkg_name cname+    = let zdashcode s = go s (Nothing :: Maybe Int) []+            where go [] _ r = reverse r+                  go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)+                  go ('-':z) _        r = go z (Just 0) ('-':r)+                  go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)+                  go (c:z)   _        r = go z Nothing (c:r)+      in PackageName $ "z-" ++ zdashcode (display pkg_name)+                   ++ "-z-" ++ zdashcode cname_str+    | otherwise+    = pkg_name++-- | In GHC 8.0, the string we pass to GHC to use for symbol+-- names for a package can be an arbitrary, IPID-compatible string.+-- However, prior to GHC 8.0 there are some restrictions on what+-- format this string can be (due to how ghc-pkg parsed the key):+--+--      1. In GHC 7.10, the string had either be of the form+--      foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated+--      prefix and ABCD is two base-64 encoded 64-bit integers,+--      or a GHC 7.8 style identifier.+--+--      2. In GHC 7.8, the string had to be a valid package identifier+--      like foo-0.1.+--+-- So, the problem is that Cabal, in general, has a general IPID,+-- but needs to figure out a package key / package ID that the+-- old ghc-pkg will actually accept.  But there's an EVERY WORSE+-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx+-- as if it were a package identifier, which means it will SILENTLY+-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)+-- So we must CONNIVE to ensure that we don't pick something that+-- looks like this.+--+-- So this function attempts to define a mapping into the old formats.+--+-- The mapping for GHC 7.8 and before:+--+--      * We use the *compatibility* package name and version.  For+--        public libraries this is just the package identifier; for+--        internal libraries, it's something like "z-pkgname-z-libname-0.1".+--        See 'computeCompatPackageName' for more details.+--+-- The mapping for GHC 7.10:+--+--      * For CLibName:+--          If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would+--          validly parse as a package key, we pass "ABCDEF".  (NB: not+--          all hashes parse this way, because GHC 7.10 mandated that+--          these hashes be two base-62 encoded 64 bit integers),+--          but hashes that Cabal generated using 'computeComponentId'+--          are guaranteed to have this form.+--+--          If it is not of this form, we rehash the IPID into the+--          correct form and pass that.+--+--      * For sub-components, we rehash the IPID into the correct format+--        and pass that.+--+computeCompatPackageKey+    :: Compiler+    -> PackageName+    -> Version+    -> UnitId+    -> String+computeCompatPackageKey comp pkg_name pkg_version (SimpleUnitId (ComponentId str))+    | not (packageKeySupported comp) =+        display pkg_name ++ "-" ++ display pkg_version+    | not (unifiedIPIDRequired comp) =+        let mb_verbatim_key+                = case simpleParse str :: Maybe PackageId of+                    -- Something like 'foo-0.1', use it verbatim.+                    -- (NB: hash tags look like tags, so they are parsed,+                    -- so the extra equality check tests if a tag was dropped.)+                    Just pid0 | display pid0 == str -> Just str+                    _ -> Nothing+            mb_truncated_key+                = let cand = reverse (takeWhile isAlphaNum (reverse str))+                  in if length cand == 22 && all isAlphaNum cand+                        then Just cand+                        else Nothing+            rehashed_key = hashToBase62 str+        in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)+    | otherwise = str+++topSortFromEdges :: Ord key => [(node, key, [key])]+                            -> [(node, key, [key])]+topSortFromEdges es =+    let (graph, vertexToNode, _) = graphFromEdges es+    in reverse (map vertexToNode (topSort graph))++mkComponentsLocalBuildInfo :: ConfigFlags+                           -> Compiler+                           -> InstalledPackageIndex+                           -> PackageDescription+                           -> [PackageId] -- internal package deps+                           -> [InstalledPackageInfo] -- external package deps+                           -> [(Component, [ComponentName])]+                           -> FlagAssignment+                           -> IO [(ComponentLocalBuildInfo,+                                   [UnitId])]+mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr+                           internalPkgDeps externalPkgDeps+                           graph flagAssignment =+    foldM go [] graph+  where+    go z (component, dep_cnames) = do+        clbi <- componentLocalBuildInfo z component+        -- NB: We want to preserve cdeps because it contains extra+        -- information like build-tools ordering+        let dep_uids = [ componentUnitId dep_clbi+                       | cname <- dep_cnames+                       -- Being in z relies on topsort!+                       , (dep_clbi, _) <- z+                       , componentLocalName dep_clbi == cname ]+        return ((clbi, dep_uids):z)++    -- The allPkgDeps contains all the package deps for the whole package+    -- but we need to select the subset for this specific component.+    -- we just take the subset for the package names this component+    -- needs. Note, this only works because we cannot yet depend on two+    -- versions of the same package.+    componentLocalBuildInfo :: [(ComponentLocalBuildInfo, [UnitId])]+                            -> Component -> IO ComponentLocalBuildInfo+    componentLocalBuildInfo internalComps component =+      case component of+      CLib lib -> do+        let exports = map (\n -> Installed.ExposedModule n Nothing)+                          (PD.exposedModules lib)+            mb_reexports = resolveModuleReexports installedPackages+                                                  (packageId pkg_descr)+                                                  uid+                                                  externalPkgDeps lib+        reexports <- case mb_reexports of+            Left problems -> reportModuleReexportProblems problems+            Right r -> return r++        return LibComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentUnitId = uid,+          componentLocalName = componentName component,+          componentIsPublic = libName lib == display (packageName (package pkg_descr)),+          componentCompatPackageKey = compat_key,+          componentCompatPackageName = compat_name,+          componentIncludes = includes,+          componentExposedModules = exports ++ reexports+        }+      CExe _ ->+        return ExeComponentLocalBuildInfo {+          componentUnitId = uid,+          componentLocalName = componentName component,+          componentPackageDeps = cpds,+          componentIncludes = includes+        }+      CTest _ ->+        return TestComponentLocalBuildInfo {+          componentUnitId = uid,+          componentLocalName = componentName component,+          componentPackageDeps = cpds,+          componentIncludes = includes+        }+      CBench _ ->+        return BenchComponentLocalBuildInfo {+          componentUnitId = uid,+          componentLocalName = componentName component,+          componentPackageDeps = cpds,+          componentIncludes = includes+        }+      where++        -- TODO configIPID should have name changed+        cid = computeComponentId (configIPID cfg) (package pkg_descr)+                (componentName component)+                (getDeps (componentName component))+                flagAssignment+        uid = SimpleUnitId cid+        PackageIdentifier pkg_name pkg_ver = package pkg_descr+        compat_name = computeCompatPackageName pkg_name (componentName component)+        compat_key = computeCompatPackageKey comp compat_name pkg_ver uid++        bi = componentBuildInfo component++        lookupInternalPkg :: PackageId -> UnitId+        lookupInternalPkg pkgid = do+            let matcher (clbi, _)+                    | CLibName str <- componentLocalName clbi+                    , str == display (pkgName pkgid)+                    = Just (componentUnitId clbi)+                matcher _ = Nothing+            case catMaybes (map matcher internalComps) of+                [x] -> x+                _ -> error "lookupInternalPkg"++        cpds = if newPackageDepsBehaviour pkg_descr+               then dedup $+                    [ (Installed.installedUnitId pkg, packageId pkg)+                    | pkg <- selectSubset bi externalPkgDeps ]+                 ++ [ (lookupInternalPkg pkgid, pkgid)+                    | pkgid <- selectSubset bi internalPkgDeps ]+               else [ (Installed.installedUnitId pkg, packageId pkg)+                    | pkg <- externalPkgDeps ]+        includes = map (\(i,p) -> (i,lookupRenaming p cprns)) cpds+        cprns = if newPackageDepsBehaviour pkg_descr+                then targetBuildRenaming bi+                else Map.empty++    dedup = Map.toList . Map.fromList++    -- TODO: this should include internal deps too+    getDeps :: ComponentName -> [ComponentId]+    getDeps cname =+      let externalPkgs+            = maybe [] (\lib -> selectSubset (componentBuildInfo lib)+                                             externalPkgDeps)+                       (lookupComponent pkg_descr cname)+      in map Installed.installedComponentId externalPkgs++    selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]+    selectSubset bi pkgs =+        [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ]++    names :: BuildInfo -> [PackageName]+    names bi = [ name | Dependency name _ <- targetBuildDepends bi ]++-- | Given the author-specified re-export declarations from the .cabal file,+-- resolve them to the form that we need for the package database.+--+-- An invariant of the package database is that we always link the re-export+-- directly to its original defining location (rather than indirectly via a+-- chain of re-exporting packages).+--+resolveModuleReexports :: InstalledPackageIndex+                       -> PackageId+                       -> UnitId+                       -> [InstalledPackageInfo]+                       -> Library+                       -> Either [(ModuleReexport, String)] -- errors+                                 [Installed.ExposedModule] -- ok+resolveModuleReexports installedPackages srcpkgid key externalPkgDeps lib =+    case partitionEithers+         (map resolveModuleReexport (PD.reexportedModules lib)) of+      ([],  ok) -> Right ok+      (errs, _) -> Left  errs+  where+    -- A mapping from visible module names to their original defining+    -- module name.  We also record the package name of the package which+    -- *immediately* provided the module (not the original) to handle if the+    -- user explicitly says which build-depends they want to reexport from.+    visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)]+    visibleModules =+      Map.fromListWith (++) $+        [ (Installed.exposedName exposedModule, [(exportingPackageName,+                                                  exposedModule)])+          -- The package index here contains all the indirect deps of the+          -- package we're configuring, but we want just the direct deps+        | let directDeps = Set.fromList+                           (map Installed.installedUnitId externalPkgDeps)+        , pkg <- PackageIndex.allPackages installedPackages+        , Installed.installedUnitId pkg `Set.member` directDeps+        , let exportingPackageName = packageName pkg+        , exposedModule <- visibleModuleDetails pkg+        ]+     ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)])+        | visibleModuleName <- PD.exposedModules lib+                            ++ otherModules (libBuildInfo lib)+        , let exportingPackageName = packageName srcpkgid+              definingModuleName   = visibleModuleName+              definingPackageId    = key+              originalModule = Module definingPackageId+                                      definingModuleName+              exposedModule  = Installed.ExposedModule visibleModuleName+                                                       (Just originalModule)+        ]++    -- All the modules exported from this package and their defining name and+    -- package (either defined here in this package or re-exported from some+    -- other package).  Return an ExposedModule because we want to hold onto+    -- signature information.+    visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule]+    visibleModuleDetails pkg = do+        exposedModule <- Installed.exposedModules pkg+        case Installed.exposedReexport exposedModule of+        -- The first case is the modules actually defined in this package.+        -- In this case the reexport will point to this package.+            Nothing -> return exposedModule {+              Installed.exposedReexport =+                 Just (Module+                       (Installed.installedUnitId pkg)+                       (Installed.exposedName exposedModule)) }+        -- On the other hand, a visible module might actually be itself+        -- a re-export! In this case, the re-export info for the package+        -- doing the re-export will point us to the original defining+        -- module name and package, so we can reuse the entry.+            Just _ -> return exposedModule++    resolveModuleReexport reexport@ModuleReexport {+         moduleReexportOriginalPackage = moriginalPackageName,+         moduleReexportOriginalName    = originalName,+         moduleReexportName            = newName+      } =++      let filterForSpecificPackage =+            case moriginalPackageName of+              Nothing                  -> id+              Just originalPackageName ->+                filter (\(pkgname, _) -> pkgname == originalPackageName)++          matches = filterForSpecificPackage+                      (Map.findWithDefault [] originalName visibleModules)+      in+      case (matches, moriginalPackageName) of+        ((_, exposedModule):rest, _)+          -- TODO: Refine this check for signatures+          | all (\(_, exposedModule') ->+                  Installed.exposedReexport exposedModule+                  == Installed.exposedReexport exposedModule') rest+           -> Right exposedModule { Installed.exposedName = newName }++        ([], Just originalPackageName)+           -> Left $ (,) reexport+                   $ "The package " ++ display originalPackageName+                  ++ " does not export a module " ++ display originalName++        ([], Nothing)+           -> Left $ (,) reexport+                   $ "The module " ++ display originalName+                  ++ " is not exported by any suitable package (this package "+                  ++ "itself nor any of its 'build-depends' dependencies)."++        (ms, _)+           -> Left $ (,) reexport+                   $ "The module " ++ display originalName ++ " is exported "+                  ++ "by more than one package ("+                  ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ]+                  ++ ") and so the re-export is ambiguous. The ambiguity can "+                  ++ "be resolved by qualifying by the package name. The "+                  ++ "syntax is 'packagename:moduleName [as newname]'."++        -- Note: if in future Cabal allows directly depending on multiple+        -- instances of the same package (e.g. backpack) then an additional+        -- ambiguity case is possible here: (_, Just originalPackageName)+        -- with the module being ambiguous despite being qualified by a+        -- package name. Presumably by that time we'll have a mechanism to+        -- qualify the instance we're referring to.++reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a+reportModuleReexportProblems reexportProblems =+  die $ unlines+    [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg+    | (reexport, msg) <- reexportProblems ]++-- -----------------------------------------------------------------------------+-- Testing C lib and header dependencies++-- Try to build a test C program which includes every header and links every+-- lib. If that fails, try to narrow it down by preprocessing (only) and linking+-- with individual headers and libs.  If none is the obvious culprit then give a+-- generic error message.+-- TODO: produce a log file from the compiler errors, if any.+checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()+checkForeignDeps pkg lbi verbosity = do+  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling+                                                               -- lucky+           (return ())+           (do missingLibs <- findMissingLibs+               missingHdr  <- findOffendingHdr+               explainErrors missingHdr missingLibs)+      where+        allHeaders = collectField PD.includes+        allLibs    = collectField PD.extraLibs++        ifBuildsWith headers args success failure = do+            ok <- builds (makeProgram headers) args+            if ok then success else failure++        findOffendingHdr =+            ifBuildsWith allHeaders ccArgs+                         (return Nothing)+                         (go . tail . inits $ allHeaders)+            where+              go [] = return Nothing       -- cannot happen+              go (hdrs:hdrsInits) =+                    -- Try just preprocessing first+                    ifBuildsWith hdrs cppArgs+                      -- If that works, try compiling too+                      (ifBuildsWith hdrs ccArgs+                        (go hdrsInits)+                        (return . Just . Right . last $ hdrs))+                      (return . Just . Left . last $ hdrs)++              cppArgs = "-E":commonCppArgs -- preprocess only+              ccArgs  = "-c":commonCcArgs  -- don't try to link++        findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)+                                       (return [])+                                       (filterM (fmap not . libExists) allLibs)++        libExists lib = builds (makeProgram []) (makeLdArgs [lib])++        commonCppArgs = platformDefines lbi+                     -- TODO: This is a massive hack, to work around the+                     -- fact that the test performed here should be+                     -- PER-component (c.f. the "I'm Feeling Lucky"; we+                     -- should NOT be glomming everything together.)+                     ++ [ "-I" ++ buildDir lbi </> "autogen" ]+                     ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]+                     ++ ["-I."]+                     ++ collectField PD.cppOptions+                     ++ collectField PD.ccOptions+                     ++ [ "-I" ++ dir+                        | dep <- deps+                        , dir <- Installed.includeDirs dep ]+                     ++ [ opt+                        | dep <- deps+                        , opt <- Installed.ccOptions dep ]++        commonCcArgs  = commonCppArgs+                     ++ collectField PD.ccOptions+                     ++ [ opt+                        | dep <- deps+                        , opt <- Installed.ccOptions dep ]++        commonLdArgs  = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ]+                     ++ collectField PD.ldOptions+                     ++ [ "-L" ++ dir+                        | dep <- deps+                        , dir <- Installed.libraryDirs dep ]+                     --TODO: do we also need dependent packages' ld options?+        makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs++        makeProgram hdrs = unlines $+                           [ "#include \""  ++ hdr ++ "\"" | hdr <- hdrs ] +++                           ["int main(int argc, char** argv) { return 0; }"]++        collectField f = concatMap f allBi+        allBi = allBuildInfo pkg+        deps = PackageIndex.topologicalOrder (installedPkgs lbi)++        builds program args = do+            tempDir <- getTemporaryDirectory+            withTempFile tempDir ".c" $ \cName cHnd ->+              withTempFile tempDir "" $ \oNname oHnd -> do+                hPutStrLn cHnd program+                hClose cHnd+                hClose oHnd+                _ <- rawSystemProgramStdoutConf verbosity+                  gccProgram (withPrograms lbi) (cName:"-o":oNname:args)+                return True+           `catchIO`   (\_ -> return False)+           `catchExit` (\_ -> return False)++        explainErrors Nothing [] = return () -- should be impossible!+        explainErrors _ _+           | isNothing . lookupProgram gccProgram . withPrograms $ lbi++                              = die $ unlines $+              [ "No working gcc",+                  "This package depends on foreign library but we cannot "+               ++ "find a working C compiler. If you have it in a "+               ++ "non-standard location you can use the --with-gcc "+               ++ "flag to specify it." ]++        explainErrors hdr libs = die $ unlines $+             [ if plural+                 then "Missing dependencies on foreign libraries:"+                 else "Missing dependency on a foreign library:"+             | missing ]+          ++ case hdr of+               Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]+               _             -> []+          ++ case libs of+               []    -> []+               [lib] -> ["* Missing C library: " ++ lib]+               _     -> ["* Missing C libraries: " ++ intercalate ", " libs]+          ++ [if plural then messagePlural else messageSingular | missing]+          ++ case hdr of+               Just (Left  _) -> [ headerCppMessage ]+               Just (Right h) -> [ (if missing then "* " else "")+                                   ++ "Bad header file: " ++ h+                                 , headerCcMessage ]+               _              -> []++          where+            plural  = length libs >= 2+            -- Is there something missing? (as opposed to broken)+            missing = not (null libs)+                   || case hdr of Just (Left _) -> True; _ -> False++        messageSingular =+             "This problem can usually be solved by installing the system "+          ++ "package that provides this library (you may need the "+          ++ "\"-dev\" version). If the library is already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where it is."+        messagePlural =+             "This problem can usually be solved by installing the system "+          ++ "packages that provide these libraries (you may need the "+          ++ "\"-dev\" versions). If the libraries are already installed "+          ++ "but in a non-standard location then you can use the flags "+          ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "+          ++ "where they are."+        headerCppMessage =+             "If the header file does exist, it may contain errors that "+          ++ "are caught by the C compiler at the preprocessing stage. "+          ++ "In this case you can re-run configure with the verbosity "+          ++ "flag -v3 to see the error messages."+        headerCcMessage =+             "The header file contains a compile error. "+          ++ "You can re-run configure with the verbosity flag "+          ++ "-v3 to see the error messages from the C compiler."++-- | Output package check warnings and errors. Exit if any errors.+checkPackageProblems :: Verbosity+                     -> GenericPackageDescription+                     -> PackageDescription+                     -> IO ()+checkPackageProblems verbosity gpkg pkg = do+  ioChecks      <- checkPackageFiles pkg "."+  let pureChecks = checkPackage gpkg (Just pkg)+      errors   = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ]+      warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]+  if null errors+    then mapM_ (warn verbosity) warnings+    else die (intercalate "\n\n" errors)++-- | Preform checks if a relocatable build is allowed+checkRelocatable :: Verbosity+                 -> PackageDescription+                 -> LocalBuildInfo+                 -> IO ()+checkRelocatable verbosity pkg lbi+    = sequence_ [ checkOS+                , checkCompiler+                , packagePrefixRelative+                , depsPrefixRelative+                ]+  where+    -- Check if the OS support relocatable builds.+    --+    -- If you add new OS' to this list, and your OS supports dynamic libraries+    -- and RPATH, make sure you add your OS to RPATH-support list of:+    -- Distribution.Simple.GHC.getRPaths+    checkOS+        = unless (os `elem` [ OSX, Linux ])+        $ die $ "Operating system: " ++ display os +++                ", does not support relocatable builds"+      where+        (Platform _ os) = hostPlatform lbi++    -- Check if the Compiler support relocatable builds+    checkCompiler+        = unless (compilerFlavor comp `elem` [ GHC ])+        $ die $ "Compiler: " ++ show comp +++                ", does not support relocatable builds"+      where+        comp = compiler lbi++    -- Check if all the install dirs are relative to same prefix+    packagePrefixRelative+        = unless (relativeInstallDirs installDirs)+        $ die $ "Installation directories are not prefix_relative:\n" +++                show installDirs+      where+        -- NB: should be good enough to check this against the default+        -- component ID, but if we wanted to be strictly correct we'd+        -- check for each ComponentId.+        installDirs = absoluteInstallDirs pkg lbi NoCopyDest+        p           = prefix installDirs+        relativeInstallDirs (InstallDirs {..}) =+          all isJust+              (fmap (stripPrefix p)+                    [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir+                    , docdir, mandir, htmldir, haddockdir, sysconfdir] )++    -- Check if the library dirs of the dependencies that are in the package+    -- database to which the package is installed are relative to the+    -- prefix of the package+    depsPrefixRelative = do+        pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi))+        mapM_ (doCheck pkgr) ipkgs+      where+        doCheck pkgr ipkg+          | maybe False (== pkgr) (Installed.pkgRoot ipkg)+          = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))+                  (Installed.libraryDirs ipkg)+          | otherwise+          = return ()+        -- NB: should be good enough to check this against the default+        -- component ID, but if we wanted to be strictly correct we'd+        -- check for each ComponentId.         installDirs   = absoluteInstallDirs pkg lbi NoCopyDest         p             = prefix installDirs         ipkgs         = PackageIndex.allPackages (installedPkgs lbi)
cabal/Cabal/Distribution/Simple/GHC.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.GHC@@ -33,7 +34,10 @@  module Distribution.Simple.GHC (         getGhcInfo,-        configure, getInstalledPackages, getPackageDBContents,+        configure,+        getInstalledPackages,+        getInstalledPackagesMonitorFiles,+        getPackageDBContents,         buildLib, buildExe,         replLib, replExe,         startInterpreter,@@ -49,74 +53,52 @@         pkgRoot  ) where -import qualified Distribution.Simple.GHC.IPI641 as IPI641+import Control.Applicative -- 7.10 -Werror workaround+import Prelude             -- https://ghc.haskell.org/trac/ghc/wiki/Migration/7.10#GHCsaysTheimportof...isredundant+ import qualified Distribution.Simple.GHC.IPI642 as IPI642 import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.GHC.ImplInfo import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)-         , allExtensions, libModules, exeModules-         , hcOptions, hcSharedOptions, hcProfOptions )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )+import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , absoluteInstallDirs, depLibraryPaths ) import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput, requireProgramVersion, requireProgram-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , ghcProgram, ghcPkgProgram, haddockProgram, hsc2hsProgram, ldProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar    as Ar import qualified Distribution.Simple.Program.Ld    as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC import Distribution.Simple.Setup-         ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref ) import qualified Distribution.Simple.Setup as Cabal-        ( Flag(..) )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , PackageDB(..), PackageDBStack, AbiTag(..) )+import Distribution.Simple.Compiler hiding (Flag) import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion ) import Distribution.System-         ( Platform(..), OS(..) ) import Distribution.Verbosity import Distribution.Text-         ( display ) import Distribution.Utils.NubList-         ( NubListR, overNubListR, toNubListR )-import Language.Haskell.Extension (Extension(..), KnownExtension(..))+import Language.Haskell.Extension  import Control.Monad            ( unless, when ) import Data.Char                ( isDigit, isSpace ) import Data.List-import qualified Data.Map as M  ( fromList )+import qualified Data.Map as M  ( fromList, lookup ) import Data.Maybe               ( catMaybes )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif+import Data.Monoid as Mon       ( Monoid(..) ) import Data.Version             ( showVersion ) import System.Directory-         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension,-                                  splitExtension, isRelative )+         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing+         , canonicalizePath )+import System.FilePath          ( (</>), (<.>), takeExtension+                                , takeDirectory, replaceExtension+                                , isRelative ) import qualified System.Info  -- -----------------------------------------------------------------------------@@ -129,7 +111,7 @@    (ghcProg, ghcVersion, conf1) <-     requireProgramVersion verbosity ghcProgram-      (orLaterVersion (Version [6,4] []))+      (orLaterVersion (Version [6,11] []))       (userMaybeSpecifyPath "ghc" hcPath conf0)   let implInfo = ghcVersionImplInfo ghcVersion @@ -154,15 +136,29 @@       haddockProgram' = haddockProgram {                            programFindLocation = guessHaddockFromGhcPath ghcProg                        }+      hpcProgram' = hpcProgram {+                        programFindLocation = guessHpcFromGhcPath ghcProg+                    }       conf3 = addKnownProgram haddockProgram' $-              addKnownProgram hsc2hsProgram' conf2+              addKnownProgram hsc2hsProgram' $+              addKnownProgram hpcProgram' conf2    languages  <- Internal.getLanguages verbosity implInfo ghcProg-  extensions <- Internal.getExtensions verbosity implInfo ghcProg+  extensions0 <- Internal.getExtensions verbosity implInfo ghcProg    ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg   let ghcInfoMap = M.fromList ghcInfo +      -- starting with GHC 8.0, `TemplateHaskell` will be omitted from+      -- `--supported-extensions` when it's not available.+      -- for older GHCs we can use the "Have interpreter" property to+      -- filter out `TemplateHaskell`+      extensions | ghcVersion < Version [8] []+                 , Just "NO" <- M.lookup "Have interpreter" ghcInfoMap+                   = filter ((/= EnableExtension TemplateHaskell) . fst)+                     extensions0+                 | otherwise = extensions0+   let comp = Compiler {         compilerId         = CompilerId GHC ghcVersion,         compilerAbiTag     = NoAbiTag,@@ -186,30 +182,42 @@ -- guessToolFromGhcPath :: Program -> ConfiguredProgram                      -> Verbosity -> ProgramSearchPath-                     -> IO (Maybe FilePath)+                     -> IO (Maybe (FilePath, [FilePath])) guessToolFromGhcPath tool ghcProg verbosity searchpath   = do let toolname          = programName tool-           path              = programPath ghcProg-           dir               = takeDirectory path-           versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> toolname <.> exeExtension-           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)-                               <.> exeExtension-           guessVersioned    = dir </> (toolname ++ versionSuffix)-                               <.> exeExtension-           guesses | null versionSuffix = [guessNormal]-                   | otherwise          = [guessGhcVersioned,-                                           guessVersioned,-                                           guessNormal]+           given_path        = programPath ghcProg+           given_dir         = takeDirectory given_path+       real_path <- canonicalizePath given_path+       let real_dir           = takeDirectory real_path+           versionSuffix path = takeVersionSuffix (dropExeExtension path)+           given_suf = versionSuffix given_path+           real_suf  = versionSuffix real_path+           guessNormal       dir = dir </> toolname <.> exeExtension+           guessGhcVersioned dir suf = dir </> (toolname ++ "-ghc" ++ suf)+                                           <.> exeExtension+           guessVersioned    dir suf = dir </> (toolname ++ suf)+                                           <.> exeExtension+           mkGuesses dir suf | null suf  = [guessNormal dir]+                             | otherwise = [guessGhcVersioned dir suf,+                                            guessVersioned dir suf,+                                            guessNormal dir]+           guesses = mkGuesses given_dir given_suf +++                            if real_path == given_path+                                then []+                                else mkGuesses real_dir real_suf        info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ dir+         ++ " near compiler in " ++ given_dir+       debug verbosity $ "candidate locations: " ++ show guesses        exists <- mapM doesFileExist guesses        case [ file | (file, True) <- zip guesses exists ] of                    -- If we can't find it near ghc, fall back to the usual                    -- method.          []     -> programFindLocation tool verbosity searchpath          (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp-                      return (Just fp)+                      let lookedAt = map fst+                                   . takeWhile (\(_file, exist) -> not exist)+                                   $ zip guesses exists+                      return (Just (fp, lookedAt))    where takeVersionSuffix :: FilePath -> String         takeVersionSuffix = takeWhileEndLE isSuffixChar@@ -217,12 +225,6 @@         isSuffixChar :: Char -> Bool         isSuffixChar c = isDigit c || c == '.' || c == '-' -        dropExeExtension :: FilePath -> FilePath-        dropExeExtension filepath =-          case splitExtension filepath of-            (filepath', extension) | extension == exeExtension -> filepath'-                                   | otherwise                 -> filepath- -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding ghc-pkg, we try looking for both a versioned and unversioned -- ghc-pkg in the same dir, that is:@@ -232,7 +234,8 @@ -- > /usr/local/bin/ghc-pkg(.exe) -- guessGhcPkgFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+                       -> Verbosity -> ProgramSearchPath+                       -> IO (Maybe (FilePath, [FilePath])) guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram  -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a@@ -244,7 +247,8 @@ -- > /usr/local/bin/hsc2hs(.exe) -- guessHsc2hsFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+                       -> Verbosity -> ProgramSearchPath+                       -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram  -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a@@ -256,9 +260,16 @@ -- > /usr/local/bin/haddock(.exe) -- guessHaddockFromGhcPath :: ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+                       -> Verbosity -> ProgramSearchPath+                       -> IO (Maybe (FilePath, [FilePath])) guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram +guessHpcFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath+                       -> IO (Maybe (FilePath, [FilePath]))+guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram++ getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg   where@@ -273,7 +284,8 @@   toPackageIndex verbosity pkgss conf  -- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration+getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack+                     -> ProgramConfiguration                      -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs conf = do   checkPackageDbEnvVar@@ -304,7 +316,7 @@   topDir <- getLibDir' verbosity ghcProg   let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)                 | (_, pkgs) <- pkgss ]-  return $! (mconcat indices)+  return $! mconcat indices    where     Just ghcProg = lookupProgram ghcProgram conf@@ -327,6 +339,23 @@     dropWhileEndLE isSpace `fmap`      rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"] +-- | Return the 'FilePath' to the per-user GHC package database.+getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath+getUserPackageDB _verbosity ghcProg (Platform arch os) = do+    -- It's rather annoying that we have to reconstruct this, because ghc+    -- hides this information from us otherwise. But for certain use cases+    -- like change monitoring it really can't remain hidden.+    appdir <- getAppUserDataDirectory "ghc"+    return (appdir </> platformAndVersion </> packageConfFileName)+  where+    platformAndVersion = intercalate "-" [ Internal.showArchString arch+                                         , Internal.showOsString os+                                         , display ghcVersion ]+    packageConfFileName+      | ghcVersion >= Version [6,12] []  = "package.conf.d"+      | otherwise                        = "package.conf"+    Just ghcVersion = programVersion ghcProg+ checkPackageDbEnvVar :: IO () checkPackageDbEnvVar =     Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH"@@ -405,14 +434,41 @@       = \file content -> case reads content of           [(pkgs, _)] -> return (map IPI642.toCurrent pkgs)           _           -> failToRead file+      -- We dropped support for 6.4.2 and earlier.       | otherwise-      = \file content -> case reads content of-          [(pkgs, _)] -> return (map IPI641.toCurrent pkgs)-          _           -> failToRead file+      = \file _ -> failToRead file     Just ghcProg = lookupProgram ghcProgram conf     Just ghcVersion = programVersion ghcProg     failToRead file = die $ "cannot read ghc package database " ++ file +getInstalledPackagesMonitorFiles :: Verbosity -> Platform+                                 -> ProgramConfiguration+                                 -> [PackageDB]+                                 -> IO [FilePath]+getInstalledPackagesMonitorFiles verbosity platform progdb =+    mapM getPackageDBPath+  where+    getPackageDBPath :: PackageDB -> IO FilePath+    getPackageDBPath GlobalPackageDB =+      selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg++    getPackageDBPath UserPackageDB =+      selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform++    getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path++    -- GHC has old style file dbs, and new style directory dbs.+    -- Note that for dir style dbs, we only need to monitor the cache file, not+    -- the whole directory. The ghc program itself only reads the cache file+    -- so it's safe to only monitor this one file.+    selectMonitorFile path = do+      isFileStyle <- doesFileExist path+      if isFileStyle then return path+                     else return (path </> "package.cache")++    Just ghcProg = lookupProgram ghcProgram progdb++ -- ----------------------------------------------------------------------------- -- Building @@ -428,8 +484,8 @@                -> PackageDescription -> LocalBuildInfo                -> Library            -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do-  let libName = componentLibraryName clbi-      libTargetDir = buildDir lbi+  let uid = componentUnitId clbi+      libTargetDir = componentBuildDir lbi clbi       whenVanillaLib forceVanilla =         when (forceVanilla || withVanillaLib lbi)       whenProfLib = when (withProfLib lbi)@@ -440,10 +496,10 @@       comp = compiler lbi       ghcVersion = compilerVersion comp       implInfo  = getImplInfo comp-      (Platform _hostArch hostOS) = hostPlatform lbi+      platform@(Platform _hostArch hostOS) = hostPlatform lbi    (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg comp+  let runGhcProg = runGHC verbosity ghcProg comp platform    libBi <- hackThreadedFlag verbosity              comp (withProfLib lbi) (libBuildInfo lib)@@ -458,13 +514,15 @@   -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.   let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi-      -- Component name. Not 'libName' because that has the "HS" prefix-      -- that GHC gives Haskell libraries.-      cname = display $ PD.package $ localPkgDescr lbi+      -- TODO: Historically HPC files have been put into a directory which+      -- has the package name.  I'm going to avoid changing this for+      -- now, but it would probably be better for this to be the+      -- component ID instead...+      pkg_name = display $ PD.package $ localPkgDescr lbi       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way-        | forRepl = mempty  -- HPC is not supported in ghci-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname+        | forRepl = Mon.mempty  -- HPC is not supported in ghci+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name         | otherwise = mempty    createDirectoryIfMissingVerbose verbosity True libTargetDir@@ -498,17 +556,20 @@                       ghcOptHPCDir      = hpcdir Hpc.Dyn                     }       linkerOpts = mempty {-                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,+                      ghcOptLinkOptions       = toNubListR $ PD.ldOptions libBi,+                      ghcOptLinkLibs          = toNubListR $ extraLibs libBi,+                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs libBi,+                      ghcOptLinkFrameworks    = toNubListR $+                                                PD.frameworks libBi,+                      ghcOptLinkFrameworkDirs = toNubListR $+                                                PD.extraFrameworkDirs libBi,                       ghcOptInputFiles     = toNubListR                                              [libTargetDir </> x | x <- cObjs]                    }       replOpts    = vanillaOpts {                       ghcOptExtra        = overNubListR                                            Internal.filterGhciFlags $-                                           (ghcOptExtra vanillaOpts),+                                           ghcOptExtra vanillaOpts,                       ghcOptNumJobs      = mempty                     }                     `mappend` linkerOpts@@ -535,7 +596,7 @@           then do               runGhcProg vanillaSharedOpts               case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do+                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) ->                     -- When the vanilla and shared library builds are done                     -- in one pass, only one set of HPC module interfaces                     -- are generated. This set should suffice for both@@ -571,12 +632,13 @@                                }                odir          = fromFlag (ghcOptObjDir vanillaCcOpts)            createDirectoryIfMissingVerbose verbosity True odir-           needsRecomp <- checkNeedsRecompilation filename vanillaCcOpts-           when needsRecomp $ do-               runGhcProg vanillaCcOpts-               unless forRepl $-                 whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)-               unless forRepl $ whenProfLib (runGhcProg profCcOpts)+           let runGhcProgIfNeeded ccOpts = do+                 needsRecomp <- checkNeedsRecompilation filename ccOpts+                 when needsRecomp $ runGhcProg ccOpts+           runGhcProgIfNeeded vanillaCcOpts+           unless forRepl $+             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)+           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)       | filename <- cSources libBi]    -- TODO: problem here is we need the .c files built first, so we can load them@@ -594,25 +656,25 @@                       (cSources libBi)         cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))                       (cSources libBi)-        cid = compilerId (compiler lbi)-        vanillaLibFilePath = libTargetDir </> mkLibName           libName-        profileLibFilePath = libTargetDir </> mkProfLibName       libName-        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName-        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName-        libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-        sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName+        compiler_id = compilerId (compiler lbi)+        vanillaLibFilePath = libTargetDir </> mkLibName uid+        profileLibFilePath = libTargetDir </> mkProfLibName uid+        sharedLibFilePath  = libTargetDir </> mkSharedLibName compiler_id uid+        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid+        libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest+        sharedLibInstallPath = libInstallPath </> mkSharedLibName compiler_id uid -    stubObjs <- fmap catMaybes $ sequence+    stubObjs <- catMaybes <$> sequence       [ findFileWithExtension [objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")       | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files       , x <- libModules lib ]-    stubProfObjs <- fmap catMaybes $ sequence+    stubProfObjs <- catMaybes <$> sequence       [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")       | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files       , x <- libModules lib ]-    stubSharedObjs <- fmap catMaybes $ sequence+    stubSharedObjs <- catMaybes <$> sequence       [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]           (ModuleName.toFilePath x ++"_stub")       | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files@@ -621,12 +683,12 @@     hObjs     <- Internal.getHaskellObjects implInfo lib lbi                       libTargetDir objExtension True     hProfObjs <--      if (withProfLib lbi)+      if withProfLib lbi               then Internal.getHaskellObjects implInfo lib lbi                       libTargetDir ("p_" ++ objExtension) True               else return []     hSharedObjs <--      if (withSharedLib lbi)+      if withSharedLib lbi               then Internal.getHaskellObjects implInfo lib lbi                       libTargetDir ("dyn_" ++ objExtension) False               else return []@@ -659,11 +721,13 @@                 ghcOptDynLinkMode        = toFlag GhcDynamicOnly,                 ghcOptInputFiles         = toNubListR dynamicObjectFiles,                 ghcOptOutputFile         = toFlag sharedLibFilePath,+                ghcOptExtra              = toNubListR $+                                           hcSharedOptions GHC libBi,                 -- For dynamic libs, Mac OS/X needs to know the install location                 -- at build time. This only applies to GHC < 7.8 - see the                 -- discussion in #1660.-                ghcOptDylibName          = if (hostOS == OSX-                                               && ghcVersion < Version [7,8] [])+                ghcOptDylibName          = if hostOS == OSX+                                              && ghcVersion < Version [7,8] []                                             then toFlag sharedLibInstallPath                                             else mempty,                 ghcOptNoAutoLinkPackages = toFlag True,@@ -673,15 +737,17 @@                 ghcOptLinkLibs           = toNubListR $ extraLibs libBi,                 ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,                 ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,+                ghcOptLinkFrameworkDirs  =+                  toNubListR $ PD.extraFrameworkDirs libBi,                 ghcOptRPaths             = rpaths               }        info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) -      whenVanillaLib False $ do+      whenVanillaLib False $         Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles -      whenProfLib $ do+      whenProfLib $         Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles        whenGHCiLib $ do@@ -693,16 +759,16 @@         runGhcProg ghcSharedLinkArgs  -- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform                  -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp packageDBs = do+startInterpreter verbosity conf comp platform packageDBs = do   let replOpts = mempty {         ghcOptMode       = toFlag GhcModeInteractive,         ghcOptPackageDBs = packageDBs         }   checkPackageDbStack comp packageDBs   (ghcProg, _) <- requireProgram verbosity ghcProgram conf-  runGHC verbosity ghcProg comp replOpts+  runGHC verbosity ghcProg comp platform replOpts  -- | Build an executable with GHC. --@@ -720,8 +786,9 @@    (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)   let comp       = compiler lbi+      platform   = hostPlatform lbi       implInfo   = getImplInfo comp-      runGhcProg = runGHC verbosity ghcProg comp+      runGhcProg = runGHC verbosity ghcProg comp platform    exeBi <- hackThreadedFlag verbosity              comp (withProfExe lbi) (buildInfo exe)@@ -732,8 +799,8 @@                        then exeExtension                        else "") -  let targetDir = (buildDir lbi) </> exeName'-  let exeDir    = targetDir </> (exeName' ++ "-tmp")+  let targetDir = componentBuildDir lbi clbi+      exeDir    = targetDir </> (exeName' ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir   createDirectoryIfMissingVerbose verbosity True exeDir   -- TODO: do we need to put hs-boot files into place for mutually recursive@@ -773,10 +840,11 @@       profOpts   = baseOpts `mappend` mempty {                       ghcOptProfilingMode  = toFlag True,                       ghcOptProfilingAuto  = Internal.profDetailLevelFlag False-                                               (withProfExeDetail lbi),+                                             (withProfExeDetail lbi),                       ghcOptHiSuffix       = toFlag "p_hi",                       ghcOptObjSuffix      = toFlag "p_o",-                      ghcOptExtra          = toNubListR (hcProfOptions GHC exeBi),+                      ghcOptExtra          = toNubListR+                                             (hcProfOptions GHC exeBi),                       ghcOptHPCDir         = hpcdir Hpc.Prof                     }       dynOpts    = baseOpts `mappend` mempty {@@ -794,10 +862,13 @@                       ghcOptHPCDir         = hpcdir Hpc.Dyn                     }       linkerOpts = mempty {-                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions exeBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,+                      ghcOptLinkOptions       = toNubListR $ PD.ldOptions exeBi,+                      ghcOptLinkLibs          = toNubListR $ extraLibs exeBi,+                      ghcOptLinkLibPath       = toNubListR $ extraLibDirs exeBi,+                      ghcOptLinkFrameworks    = toNubListR $+                                                PD.frameworks exeBi,+                      ghcOptLinkFrameworkDirs = toNubListR $+                                                PD.extraFrameworkDirs exeBi,                       ghcOptInputFiles     = toNubListR                                              [exeDir </> x | x <- cObjs]                     }@@ -846,10 +917,11 @@         | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe)         | otherwise    = doingTH && (withProfExe lbi || withDynExe lbi) -      linkOpts = commonOpts `mappend`-                 linkerOpts `mappend`-                 mempty { ghcOptLinkNoHsMain   = toFlag (not isHaskellMain) } `mappend`-                 (if withDynExe lbi then dynLinkerOpts else mempty)+      linkOpts =+        commonOpts `mappend`+        linkerOpts `mappend`+        mempty { ghcOptLinkNoHsMain   = toFlag (not isHaskellMain) } `mappend`+        (if withDynExe lbi then dynLinkerOpts else mempty)    -- Build static/dynamic object files for TH, if needed.   when compileForTH $@@ -874,7 +946,7 @@               odir  = fromFlag (ghcOptObjDir opts)           createDirectoryIfMissingVerbose verbosity True odir           needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $ +          when needsRecomp $             runGhcProg opts      | filename <- cSrcs ] @@ -974,8 +1046,9 @@              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)   let       comp        = compiler lbi+      platform    = hostPlatform lbi       vanillaArgs =-        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))+        (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))         `mappend` mempty {           ghcOptMode         = toFlag GhcModeAbiHash,           ghcOptInputModules = toNubListR $ exposedModules lib@@ -995,14 +1068,15 @@                      ghcOptObjSuffix     = toFlag "p_o",                      ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi                    }-      ghcArgs = if withVanillaLib lbi then vanillaArgs-           else if withSharedLib  lbi then sharedArgs-           else if withProfLib    lbi then profArgs-           else error "libAbiHash: Can't find an enabled library way"-  --+      ghcArgs+        | withVanillaLib lbi = vanillaArgs+        | withSharedLib lbi = sharedArgs+        | withProfLib lbi = profArgs+        | otherwise = error "libAbiHash: Can't find an enabled library way"+   (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)   hash <- getProgramInvocationOutput verbosity-          (ghcInvocation ghcProg comp ghcArgs)+          (ghcInvocation ghcProg comp platform ghcArgs)   return (takeWhile (not . isSpace) hash)  componentGhcOptions :: Verbosity -> LocalBuildInfo@@ -1057,19 +1131,24 @@               -> Library               -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do+installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do   -- copy .hi files over:-  whenVanilla $ copyModuleFiles "hi"-  whenProf    $ copyModuleFiles "p_hi"-  whenShared  $ copyModuleFiles "dyn_hi"+  whenRegistered $ do+    whenVanilla $ copyModuleFiles "hi"+    whenProf    $ copyModuleFiles "p_hi"+    whenShared  $ copyModuleFiles "dyn_hi"    -- copy the built library files over:-  whenVanilla $ installOrdinary builtDir targetDir       vanillaLibName-  whenProf    $ installOrdinary builtDir targetDir       profileLibName-  whenGHCi    $ installOrdinary builtDir targetDir       ghciLibName-  whenShared  $ installShared   builtDir dynlibTargetDir sharedLibName+  whenRegistered $ do+    whenVanilla $ installOrdinary builtDir targetDir       vanillaLibName+    whenProf    $ installOrdinary builtDir targetDir       profileLibName+    whenGHCi    $ installOrdinary builtDir targetDir       ghciLibName+  whenRegisteredOrDynExecutable $ do+    whenShared  $ installShared   builtDir dynlibTargetDir sharedLibName    where+    builtDir = componentBuildDir lbi clbi+     install isShared srcDir dstDir name = do       let src = srcDir </> name           dst = dstDir </> name@@ -1089,12 +1168,12 @@       findModuleFiles [builtDir] [ext] (libModules lib)       >>= installOrdinaryFiles verbosity targetDir -    cid = compilerId (compiler lbi)-    libName = componentLibraryName clbi-    vanillaLibName = mkLibName              libName-    profileLibName = mkProfLibName          libName-    ghciLibName    = Internal.mkGHCiLibName libName-    sharedLibName  = (mkSharedLibName cid)  libName+    compiler_id = compilerId (compiler lbi)+    uid = componentUnitId clbi+    vanillaLibName = mkLibName              uid+    profileLibName = mkProfLibName          uid+    ghciLibName    = Internal.mkGHCiLibName uid+    sharedLibName  = (mkSharedLibName compiler_id) uid      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))@@ -1103,6 +1182,17 @@     whenGHCi    = when (hasLib && withGHCiLib    lbi)     whenShared  = when (hasLib && withSharedLib  lbi) +    -- Some files (e.g. interface files) are completely unnecessary when+    -- we are not actually going to register the library.  A library is+    -- not registered if there is no "public library", e.g. in the case+    -- that we have an internal library and executables, but no public+    -- library.+    whenRegistered = when (hasPublicLib pkg)++    -- However, we must always install dynamic libraries when linking+    -- dynamic executables, because we'll try to load them!+    whenRegisteredOrDynExecutable = when (hasPublicLib pkg || (hasExes pkg && withDynExe lbi))+ -- ----------------------------------------------------------------------------- -- Registering @@ -1111,7 +1201,10 @@                                  , HcPkg.noPkgDbStack    = v < [6,9]                                  , HcPkg.noVerboseFlag   = v < [6,11]                                  , HcPkg.flagPackageConf = v < [7,5]-                                 , HcPkg.useSingleFileDb = v < [7,9]+                                 , HcPkg.supportsDirDbs  = v >= [6,8]+                                 , HcPkg.requiresDirDbs  = v >= [7,10]+                                 , HcPkg.nativeMultiInstance  = v >= [7,10]+                                 , HcPkg.recacheMultiInstance = v >= [6,12]                                  }   where     v               = versionBranch ver@@ -1120,15 +1213,19 @@  registerPackage   :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool+  -> ProgramConfiguration+  -> HcPkg.MultiInstance   -> PackageDBStack+  -> InstalledPackageInfo   -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity-    packageDbs (Right installedPkgInfo)+registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo+  | HcPkg.MultiInstance <- multiInstance+  = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity+      packageDbs installedPkgInfo++  | otherwise+  = HcPkg.reregister (hcPkgInfo progdb) verbosity+      packageDbs (Right installedPkgInfo)  pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot'
− cabal/Cabal/Distribution/Simple/GHC/IPI641.hs 
@@ -1,106 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.IPI641--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-----module Distribution.Simple.GHC.IPI641 (-    InstalledPackageInfo(..),-    toCurrent,-  ) where--import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (installedPackageId)-import Distribution.Text (display)--import Distribution.Simple.GHC.IPI642-         ( PackageIdentifier, convertPackageId-         , License, convertLicense, convertModuleName )---- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1.------ It's here purely for the 'Read' instance so that we can read the package--- database used by those ghc versions. It is a little hacky to read the--- package db directly, but we do need the info and until ghc-6.9 there was--- no better method.------ In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642"----data InstalledPackageInfo = InstalledPackageInfo {-    package           :: PackageIdentifier,-    license           :: License,-    copyright         :: String,-    maintainer        :: String,-    author            :: String,-    stability         :: String,-    homepage          :: String,-    pkgUrl            :: String,-    description       :: String,-    category          :: String,-    exposed           :: Bool,-    exposedModules    :: [String],-    hiddenModules     :: [String],-    importDirs        :: [FilePath],-    libraryDirs       :: [FilePath],-    hsLibraries       :: [String],-    extraLibraries    :: [String],-    includeDirs       :: [FilePath],-    includes          :: [String],-    depends           :: [PackageIdentifier],-    hugsOptions       :: [String],-    ccOptions         :: [String],-    ldOptions         :: [String],-    frameworkDirs     :: [FilePath],-    frameworks        :: [String],-    haddockInterfaces :: [FilePath],-    haddockHTMLs      :: [FilePath]-  }-  deriving Read--mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId-mkInstalledPackageId = Current.InstalledPackageId . display--toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo-toCurrent ipi@InstalledPackageInfo{} =-  let pid = convertPackageId (package ipi)-      mkExposedModule m = Current.ExposedModule m Nothing Nothing-  in Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = pid,-    Current.packageKey         = Current.OldPackageKey pid,-    Current.license            = convertLicense (license ipi),-    Current.copyright          = copyright ipi,-    Current.maintainer         = maintainer ipi,-    Current.author             = author ipi,-    Current.stability          = stability ipi,-    Current.homepage           = homepage ipi,-    Current.pkgUrl             = pkgUrl ipi,-    Current.synopsis           = "",-    Current.description        = description ipi,-    Current.category           = category ipi,-    Current.exposed            = exposed ipi,-    Current.exposedModules     = map (mkExposedModule . convertModuleName) (exposedModules ipi),-    Current.instantiatedWith   = [],-    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,-    Current.importDirs         = importDirs ipi,-    Current.libraryDirs        = libraryDirs ipi,-    Current.dataDir            = "",-    Current.hsLibraries        = hsLibraries ipi,-    Current.extraLibraries     = extraLibraries ipi,-    Current.extraGHCiLibraries = [],-    Current.includeDirs        = includeDirs ipi,-    Current.includes           = includes ipi,-    Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),-    Current.ccOptions          = ccOptions ipi,-    Current.ldOptions          = ldOptions ipi,-    Current.frameworkDirs      = frameworkDirs ipi,-    Current.frameworks         = frameworks ipi,-    Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi,-    Current.pkgRoot            = Nothing-  }
cabal/Cabal/Distribution/Simple/GHC/IPI642.hs view
@@ -11,22 +11,11 @@ module Distribution.Simple.GHC.IPI642 (     InstalledPackageInfo(..),     toCurrent,--    -- Don't use these, they're only for conversion purposes-    PackageIdentifier, convertPackageId,-    License, convertLicense,-    convertModuleName   ) where  import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (installedPackageId)-import qualified Distribution.License as Current--import Distribution.Version (Version)-import Distribution.ModuleName (ModuleName)-import Distribution.Text (simpleParse,display)--import Data.Maybe+import qualified Distribution.Package as Current hiding (installedUnitId)+import Distribution.Simple.GHC.IPIConvert  -- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. --@@ -70,43 +59,15 @@   }   deriving Read -data PackageIdentifier = PackageIdentifier {-    pkgName    :: String,-    pkgVersion :: Version-  }-  deriving Read--data License = GPL | LGPL | BSD3 | BSD4-             | PublicDomain | AllRightsReserved | OtherLicense-  deriving Read--convertPackageId :: PackageIdentifier -> Current.PackageIdentifier-convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } =-  Current.PackageIdentifier (Current.PackageName n) v--mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId-mkInstalledPackageId = Current.InstalledPackageId . display--convertModuleName :: String -> ModuleName-convertModuleName s = fromJust $ simpleParse s--convertLicense :: License -> Current.License-convertLicense GPL  = Current.GPL  Nothing-convertLicense LGPL = Current.LGPL Nothing-convertLicense BSD3 = Current.BSD3-convertLicense BSD4 = Current.BSD4-convertLicense PublicDomain = Current.PublicDomain-convertLicense AllRightsReserved = Current.AllRightsReserved-convertLicense OtherLicense = Current.OtherLicense- toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo toCurrent ipi@InstalledPackageInfo{} =   let pid = convertPackageId (package ipi)-      mkExposedModule m = Current.ExposedModule m Nothing Nothing+      mkExposedModule m = Current.ExposedModule m Nothing   in Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),     Current.sourcePackageId    = pid,-    Current.packageKey         = Current.OldPackageKey pid,+    Current.installedUnitId    = Current.mkLegacyUnitId pid,+    Current.compatPackageKey   = "",+    Current.abiHash            = Current.AbiHash "", -- bogus but old GHCs don't care.     Current.license            = convertLicense (license ipi),     Current.copyright          = copyright ipi,     Current.maintainer         = maintainer ipi,@@ -120,7 +81,6 @@     Current.exposed            = exposed ipi,     Current.exposedModules     = map (mkExposedModule . convertModuleName) (exposedModules ipi),     Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.instantiatedWith   = [],     Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,     Current.importDirs         = importDirs ipi,     Current.libraryDirs        = libraryDirs ipi,@@ -130,7 +90,7 @@     Current.extraGHCiLibraries = extraGHCiLibraries ipi,     Current.includeDirs        = includeDirs ipi,     Current.includes           = includes ipi,-    Current.depends            = map (mkInstalledPackageId.convertPackageId) (depends ipi),+    Current.depends            = map (Current.mkLegacyUnitId . convertPackageId) (depends ipi),     Current.ccOptions          = ccOptions ipi,     Current.ldOptions          = ldOptions ipi,     Current.frameworkDirs      = frameworkDirs ipi,
+ cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC.IPI642+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Helper functions for 'Distribution.Simple.GHC.IPI642'.+module Distribution.Simple.GHC.IPIConvert (+    PackageIdentifier, convertPackageId,+    License, convertLicense,+    convertModuleName+  ) where++import qualified Distribution.Package as Current hiding (installedUnitId)+import qualified Distribution.License as Current++import Distribution.Version+import Distribution.ModuleName+import Distribution.Text++import Data.Maybe++data PackageIdentifier = PackageIdentifier {+    pkgName    :: String,+    pkgVersion :: Version+  }+  deriving Read++convertPackageId :: PackageIdentifier -> Current.PackageIdentifier+convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } =+  Current.PackageIdentifier (Current.PackageName n) v++data License = GPL | LGPL | BSD3 | BSD4+             | PublicDomain | AllRightsReserved | OtherLicense+  deriving Read++convertModuleName :: String -> ModuleName+convertModuleName s = fromJust $ simpleParse s++convertLicense :: License -> Current.License+convertLicense GPL  = Current.GPL  Nothing+convertLicense LGPL = Current.LGPL Nothing+convertLicense BSD3 = Current.BSD3+convertLicense BSD4 = Current.BSD4+convertLicense PublicDomain = Current.PublicDomain+convertLicense AllRightsReserved = Current.AllRightsReserved+convertLicense OtherLicense = Current.OtherLicense
cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs view
@@ -15,9 +15,7 @@         ) where  import Distribution.Simple.Compiler-  ( Compiler(..), CompilerFlavor(..)-  , compilerFlavor, compilerVersion, compilerCompatVersion )-import Distribution.Version ( Version(..) )+import Distribution.Version  {- |      Information about features and quirks of a GHC-based implementation.@@ -33,17 +31,7 @@ -}  data GhcImplInfo = GhcImplInfo-  { hasCcOdirBug         :: Bool -- ^ bug in -odir handling for C compilations.-  , flagInfoLanguages    :: Bool -- ^ --info and --supported-languages flags-  , fakeRecordPuns       :: Bool -- ^ use -XRecordPuns for NamedFieldPuns-  , flagStubdir          :: Bool -- ^ -stubdir flag supported-  , flagOutputDir        :: Bool -- ^ -outputdir flag supported-  , noExtInSplitSuffix   :: Bool -- ^ split-obj suffix does not contain p_o ext-  , flagFfiIncludes      :: Bool -- ^ -#include on command line for FFI includes-  , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported-  , flagPackageId        :: Bool -- ^ -package-id / -package flags supported-  , separateGccMingw     :: Bool -- ^ mingw and gcc are in separate directories-  , supportsHaskell2010  :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags+  { supportsHaskell2010  :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags   , reportsNoExt         :: Bool -- ^ --supported-languages gives Ext and NoExt   , alwaysNondecIndent   :: Bool -- ^ NondecreasingIndentation is always on   , flagGhciScript       :: Bool -- ^ -ghci-script flag supported@@ -67,17 +55,7 @@  ghcVersionImplInfo :: Version -> GhcImplInfo ghcVersionImplInfo (Version v _) = GhcImplInfo-  { hasCcOdirBug         = v <  [6,4,1]-  , flagInfoLanguages    = v >= [6,7]-  , fakeRecordPuns       = v >= [6,8] && v < [6,10]-  , flagStubdir          = v >= [6,8]-  , flagOutputDir        = v >= [6,10]-  , noExtInSplitSuffix   = v <  [6,11]-  , flagFfiIncludes      = v <  [6,11]-  , flagBuildingCabalPkg = v >= [6,11]-  , flagPackageId        = v >  [6,11]-  , separateGccMingw     = v <  [6,12]-  , supportsHaskell2010  = v >= [7]+  { supportsHaskell2010  = v >= [7]   , reportsNoExt         = v >= [7]   , alwaysNondecIndent   = v <  [7,1]   , flagGhciScript       = v >= [7,2]@@ -88,17 +66,7 @@  ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo-  { hasCcOdirBug         = False-  , flagInfoLanguages    = True-  , fakeRecordPuns       = False-  , flagStubdir          = True-  , flagOutputDir        = True-  , noExtInSplitSuffix   = False-  , flagFfiIncludes      = False-  , flagBuildingCabalPkg = True-  , flagPackageId        = True-  , separateGccMingw     = False-  , supportsHaskell2010  = True+  { supportsHaskell2010  = True   , reportsNoExt         = True   , alwaysNondecIndent   = False   , flagGhciScript       = True
cabal/Cabal/Distribution/Simple/GHC/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- |@@ -27,56 +26,40 @@         substTopDir,         checkPackageDbEnvVar,         profDetailLevelFlag,+        showArchString,+        showOsString,  ) where -import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) )+import Distribution.Simple.GHC.ImplInfo import Distribution.Package-         ( InstalledPackageId, PackageId, LibraryName-         , getHSLibraryName ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo(..) )-import Distribution.PackageDescription as PD-         ( BuildInfo(..), Library(..), libModules-         , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming )-import Distribution.Compat.Exception ( catchExit, catchIO )-import Distribution.Lex (tokenizeQuotedWords)-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..)-         , OptimisationLevel(..), ProfDetailLevel(..) )+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Compat.Exception+import Distribution.Lex+import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Program.GHC import Distribution.Simple.Setup-         ( Flag, toFlag ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)-         , rawSystemProgram, rawSystemProgramStdout, programPath-         , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram-         , getProgramOutput )-import Distribution.Simple.Program.Types ( suppressOverrideArgs ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.Utils import Distribution.Simple.BuildPaths-import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple )+import Distribution.System import Distribution.Text ( display, simpleParse ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity import Language.Haskell.Extension-         ( Language(..), Extension(..), KnownExtension(..) )  import qualified Data.Map as M import Data.Char                ( isSpace ) import Data.Maybe               ( fromMaybe, maybeToList, isJust ) import Control.Monad            ( unless, when )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif+import Data.Monoid as Mon       ( Monoid(..) ) import System.Directory         ( getDirectoryContents, getTemporaryDirectory ) import System.Environment       ( getEnv )-import System.FilePath          ( (</>), (<.>), takeExtension, takeDirectory )+import System.FilePath          ( (</>), (<.>), takeExtension+                                , takeDirectory, takeFileName) import System.IO                ( hClose, hPutStrLn )  targetPlatform :: [(String, String)] -> Maybe Platform@@ -89,30 +72,36 @@                    -> M.Map String String                    -> ProgramConfiguration                    -> ProgramConfiguration-configureToolchain implInfo ghcProg ghcInfo =+configureToolchain _implInfo ghcProg ghcInfo =     addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram extraGccPath,+      programFindLocation = findProg gccProgramName extraGccPath,       programPostConf     = configureGcc     }   . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram extraLdPath,+      programFindLocation = findProg ldProgramName extraLdPath,       programPostConf     = configureLd     }   . addKnownProgram arProgram {-      programFindLocation = findProg arProgram extraArPath+      programFindLocation = findProg arProgramName extraArPath     }   . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgram extraStripPath+      programFindLocation = findProg stripProgramName extraStripPath     }   where     compilerDir = takeDirectory (programPath ghcProg)     baseDir     = takeDirectory compilerDir     mingwBinDir = baseDir </> "mingw" </> "bin"-    libDir      = baseDir </> "gcc-lib"-    includeDir  = baseDir </> "include" </> "mingw"     isWindows   = case buildOS of Windows -> True; _ -> False     binPrefix   = "" +    maybeName :: Program -> Maybe FilePath -> String+    maybeName prog   = maybe (programName prog) (dropExeExtension . takeFileName)++    gccProgramName   = maybeName gccProgram   mbGccLocation+    ldProgramName    = maybeName ldProgram    mbLdLocation+    arProgramName    = maybeName arProgram    mbArLocation+    stripProgramName = maybeName stripProgram mbStripLocation+     mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]     mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]                                  | otherwise = mbDir@@ -126,16 +115,15 @@      -- on Windows finding and configuring ghc's gcc & binutils is a bit special     (windowsExtraGccDir, windowsExtraLdDir,-     windowsExtraArDir, windowsExtraStripDir)-      | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir)-      | otherwise                 = -- GHC >= 6.12+     windowsExtraArDir, windowsExtraStripDir) =           let b = mingwBinDir </> binPrefix           in  (b, b, b, b) -    findProg :: Program -> [FilePath]-             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)-    findProg prog extraPath v searchpath =-        programFindLocation prog v searchpath'+    findProg :: String -> [FilePath]+             -> Verbosity -> ProgramSearchPath+             -> IO (Maybe (FilePath, [FilePath]))+    findProg progName extraPath v searchpath =+        findProgramOnSearchPath v searchpath' progName       where         searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath @@ -165,28 +153,12 @@             | otherwise -> tokenizeQuotedWords flags      configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc v gccProg = do-      gccProg' <- configureGcc' v gccProg-      return gccProg' {-        programDefaultArgs = programDefaultArgs gccProg'+    configureGcc _v gccProg = do+      return gccProg {+        programDefaultArgs = programDefaultArgs gccProg                              ++ ccFlags ++ gccLinkerFlags       } -    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc'-      | isWindows = \_ gccProg -> case programLocation gccProg of-          -- if it's found on system then it means we're using the result-          -- of programFindLocation above rather than a user-supplied path-          -- Pre GHC 6.12, that meant we should add these flags to tell-          -- ghc's gcc where it lives and thus where gcc can find its-          -- various files:-          FoundOnSystem {}-           | separateGccMingw implInfo ->-               return gccProg { programDefaultArgs = ["-B" ++ libDir,-                                                      "-I" ++ includeDir] }-          _ -> return gccProg-      | otherwise = \_ gccProg -> return gccProg-     configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureLd v ldProg = do       ldProg' <- configureLd' v ldProg@@ -226,8 +198,7 @@  getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram            -> IO [(String, String)]-getGhcInfo verbosity implInfo ghcProg-  | flagInfoLanguages implInfo = do+getGhcInfo verbosity _implInfo ghcProg = do       xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)                  ["--info"]       case reads xs of@@ -236,13 +207,10 @@               return i         _ ->           die "Can't parse --info output of GHC"-  | otherwise =-      return []  getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram               -> IO [(Extension, String)]-getExtensions verbosity implInfo ghcProg-  | flagInfoLanguages implInfo = do+getExtensions verbosity implInfo ghcProg = do     str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)               ["--supported-languages"]     let extStrs = if reportsNoExt implInfo@@ -258,94 +226,27 @@                        ]     let extensions0 = [ (ext, "-X" ++ display ext)                       | Just ext <- map simpleParse extStrs ]-        extensions1 = if fakeRecordPuns implInfo-                      then -- ghc-6.8 introduced RecordPuns however it-                           -- should have been NamedFieldPuns. We now-                           -- encourage packages to use NamedFieldPuns-                           -- so for compatibility we fake support for-                           -- it in ghc-6.8 by making it an alias for-                           -- the old RecordPuns extension.-                           (EnableExtension  NamedFieldPuns, "-XRecordPuns") :-                           (DisableExtension NamedFieldPuns, "-XNoRecordPuns") :-                           extensions0-                      else extensions0-        extensions2 = if alwaysNondecIndent implInfo+        extensions1 = if alwaysNondecIndent implInfo                       then -- ghc-7.2 split NondecreasingIndentation off                            -- into a proper extension. Before that it                            -- was always on.                            (EnableExtension  NondecreasingIndentation, "") :                            (DisableExtension NondecreasingIndentation, "") :-                           extensions1-                      else extensions1-    return extensions2--  | otherwise = return oldLanguageExtensions---- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags-oldLanguageExtensions :: [(Extension, String)]-oldLanguageExtensions =-    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),-                                         (DisableExtension f, disable)]-        fglasgowExts = ("-fglasgow-exts",-                        "") -- This is wrong, but we don't want to turn-                            -- all the extensions off when asked to just-                            -- turn one off-        fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)-    in concatMap doFlag-    [(OverlappingInstances       , fFlag "allow-overlapping-instances")-    ,(TypeSynonymInstances       , fglasgowExts)-    ,(TemplateHaskell            , fFlag "th")-    ,(ForeignFunctionInterface   , fFlag "ffi")-    ,(MonomorphismRestriction    , fFlag "monomorphism-restriction")-    ,(MonoPatBinds               , fFlag "mono-pat-binds")-    ,(UndecidableInstances       , fFlag "allow-undecidable-instances")-    ,(IncoherentInstances        , fFlag "allow-incoherent-instances")-    ,(Arrows                     , fFlag "arrows")-    ,(Generics                   , fFlag "generics")-    ,(ImplicitPrelude            , fFlag "implicit-prelude")-    ,(ImplicitParams             , fFlag "implicit-params")-    ,(CPP                        , ("-cpp", ""{- Wrong -}))-    ,(BangPatterns               , fFlag "bang-patterns")-    ,(KindSignatures             , fglasgowExts)-    ,(RecursiveDo                , fglasgowExts)-    ,(ParallelListComp           , fglasgowExts)-    ,(MultiParamTypeClasses      , fglasgowExts)-    ,(FunctionalDependencies     , fglasgowExts)-    ,(Rank2Types                 , fglasgowExts)-    ,(RankNTypes                 , fglasgowExts)-    ,(PolymorphicComponents      , fglasgowExts)-    ,(ExistentialQuantification  , fglasgowExts)-    ,(ScopedTypeVariables        , fFlag "scoped-type-variables")-    ,(FlexibleContexts           , fglasgowExts)-    ,(FlexibleInstances          , fglasgowExts)-    ,(EmptyDataDecls             , fglasgowExts)-    ,(PatternGuards              , fglasgowExts)-    ,(GeneralizedNewtypeDeriving , fglasgowExts)-    ,(MagicHash                  , fglasgowExts)-    ,(UnicodeSyntax              , fglasgowExts)-    ,(PatternSignatures          , fglasgowExts)-    ,(UnliftedFFITypes           , fglasgowExts)-    ,(LiberalTypeSynonyms        , fglasgowExts)-    ,(TypeOperators              , fglasgowExts)-    ,(GADTs                      , fglasgowExts)-    ,(RelaxedPolyRec             , fglasgowExts)-    ,(ExtendedDefaultRules       , fFlag "extended-default-rules")-    ,(UnboxedTuples              , fglasgowExts)-    ,(DeriveDataTypeable         , fglasgowExts)-    ,(ConstrainedClassMethods    , fglasgowExts)-    ]+                           extensions0+                      else extensions0+    return extensions1  componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo                       -> BuildInfo -> ComponentLocalBuildInfo                       -> FilePath -> FilePath                       -> GhcOptions-componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename =+componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename =     mempty {       ghcOptVerbosity      = toFlag verbosity,       ghcOptMode           = toFlag GhcModeCompile,       ghcOptInputFiles     = toNubListR [filename], -      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]+      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi clbi, odir]                                           ++ PD.includeDirs bi,       ghcOptPackageDBs     = withPackageDB lbi,       ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,@@ -361,10 +262,6 @@                                   PD.ccOptions bi,       ghcOptObjDir         = toFlag odir     }-  where-    odir | hasCcOdirBug implInfo = pref </> takeDirectory filename-         | otherwise             = pref-         -- ghc 6.4.0 had a bug in -odir handling for C compilations.  componentGhcOptions :: Verbosity -> LocalBuildInfo                     -> BuildInfo -> ComponentLocalBuildInfo -> FilePath@@ -374,21 +271,21 @@       ghcOptVerbosity       = toFlag verbosity,       ghcOptHideAllPackages = toFlag True,       ghcOptCabal           = toFlag True,-      ghcOptPackageKey  = case clbi of-        LibComponentLocalBuildInfo { componentPackageKey = pk } -> toFlag pk-        _ -> mempty,-      ghcOptSigOf           = hole_insts,+      ghcOptThisUnitId      = case clbi of+        LibComponentLocalBuildInfo { componentCompatPackageKey = pk }+          -> toFlag pk+        _ -> Mon.mempty,       ghcOptPackageDBs      = withPackageDB lbi,       ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,       ghcOptSplitObjs       = toFlag (splitObjs lbi),       ghcOptSourcePathClear = toFlag True,       ghcOptSourcePath      = toNubListR $ [odir] ++ (hsSourceDirs bi)-                                           ++ [autogenModulesDir lbi],-      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi, odir]+                                           ++ [autogenModulesDir lbi clbi],+      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi clbi, odir]                                            ++ PD.includeDirs bi,       ghcOptCppOptions      = toNubListR $ cppOptions bi,       ghcOptCppIncludes     = toNubListR $-                              [autogenModulesDir lbi </> cppHeaderName],+                              [autogenModulesDir lbi clbi </> cppHeaderName],       ghcOptFfiIncludes     = toNubListR $ PD.includes bi,       ghcOptObjDir          = toFlag odir,       ghcOptHiDir           = toFlag odir,@@ -413,9 +310,6 @@     toGhcDebugInfo NormalDebugInfo  = toFlag True     toGhcDebugInfo MaximalDebugInfo = toFlag True -    hole_insts = map (\(k,(p,n)) -> (k, (InstalledPackageInfo.packageKey p,n)))-                 (instantiatedWith lbi)- -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported@@ -429,7 +323,7 @@     supported "-unreg"    = False     supported _           = True -mkGHCiLibName :: LibraryName -> String+mkGHCiLibName :: UnitId -> String mkGHCiLibName lib = getHSLibraryName lib <.> "o"  ghcLookupProperty :: String -> Compiler -> Bool@@ -442,11 +336,9 @@ -- Module_split directory for each module. getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo                   -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs+getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs   | splitObjs lbi && allow_split_objs = do-        let splitSuffix = if   noExtInSplitSuffix implInfo-                          then "_split"-                          else "_" ++ wanted_obj_ext ++ "_split"+        let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"             dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)                    | x <- libModules lib ]         objss <- mapM getDirectoryContents dirs@@ -460,10 +352,8 @@                | x <- libModules lib ]  mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(InstalledPackageId, PackageId, ModuleRenaming)]-mkGhcOptPackages clbi =-  map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))-      (componentPackageDeps clbi)+                 -> [(UnitId, ModuleRenaming)]+mkGhcOptPackages = componentIncludes  substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo substTopDir topDir ipo@@ -502,7 +392,8 @@         unless (mPP == mcsPP) abort     where         lookupEnv :: String -> IO (Maybe String)-        lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)+        lookupEnv name = (Just `fmap` getEnv name)+                         `catchIO` const (return Nothing)         abort =             die $ "Use of " ++ compilerName ++ "'s environment variable "                ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "@@ -519,3 +410,20 @@       ProfDetailToplevelFunctions   -> toFlag GhcProfAutoToplevel       ProfDetailAllFunctions        -> toFlag GhcProfAutoAll       ProfDetailOther _             -> mempty++-- | GHC's rendering of it's host or target 'Arch' as used in its platform+-- strings and certain file locations (such as user package db location).+--+showArchString :: Arch -> String+showArchString PPC   = "powerpc"+showArchString PPC64 = "powerpc64"+showArchString other = display other++-- | GHC's rendering of it's host or target 'OS' as used in its platform+-- strings and certain file locations (such as user package db location).+--+showOsString :: OS -> String+showOsString Windows = "mingw32"+showOsString OSX     = "darwin"+showOsString Solaris = "solaris2"+showOsString other   = display other
cabal/Cabal/Distribution/Simple/GHCJS.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-} module Distribution.Simple.GHCJS (         configure, getInstalledPackages, getPackageDBContents,         buildLib, buildExe,@@ -15,70 +15,40 @@         runCmd   ) where -import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo )+import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, exeModules-         , hcOptions, hcProfOptions, hcSharedOptions-         , allExtensions ) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo(..) )-import Distribution.Package ( LibraryName(..), getHSLibraryName )+import Distribution.Package import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath-         , rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput-         , requireProgramVersion, requireProgram-         , userMaybeSpecifyPath, programPath-         , lookupProgram, addKnownPrograms-         , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram-         , ldProgram, haddockProgram, stripProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar    as Ar import qualified Distribution.Simple.Program.Ld    as Ld import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-         ( toFlag, fromFlag, configCoverage, configDistPref )+import Distribution.Simple.Setup hiding ( Flag ) import qualified Distribution.Simple.Setup as Cabal-        ( Flag(..) )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , PackageDB(..), PackageDBStack, AbiTag(..) )+import Distribution.Simple.Compiler hiding ( Flag ) import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion ) import Distribution.System-         ( Platform(..) ) import Distribution.Verbosity import Distribution.Utils.NubList-         ( overNubListR, toNubListR )-import Distribution.Text ( display )-import Language.Haskell.Extension ( Extension(..)-                                  , KnownExtension(..))+import Distribution.Text+import Language.Haskell.Extension  import Control.Monad            ( unless, when ) import Data.Char                ( isSpace ) import qualified Data.Map as M  ( fromList  )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif+import Data.Monoid as Mon       ( Monoid(..) ) import System.Directory         ( doesFileExist )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension,-                                  splitExtension )+import System.FilePath          ( (</>), (<.>), takeExtension+                                , takeDirectory, replaceExtension )  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath           -> ProgramConfiguration@@ -155,24 +125,24 @@ ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"  guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity-                           -> ProgramSearchPath -> IO (Maybe FilePath)+                           -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram  guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity-                         -> ProgramSearchPath -> IO (Maybe FilePath)+                         -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram  guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity-                       -> ProgramSearchPath -> IO (Maybe FilePath)+                       -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram  guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity-                          -> ProgramSearchPath -> IO (Maybe FilePath)+                          -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram  guessToolFromGhcjsPath :: Program -> ConfiguredProgram                        -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe FilePath)+                       -> IO (Maybe (FilePath, [FilePath])) guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath   = do let toolname          = programName tool            path              = programPath ghcjsProg@@ -197,19 +167,15 @@                    -- method.          []     -> programFindLocation tool verbosity searchpath          (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp-                      return (Just fp)+                      let lookedAt = map fst+                                   . takeWhile (\(_file, exist) -> not exist)+                                   $ zip guesses exists+                      return (Just (fp, lookedAt))    where takeVersionSuffix :: FilePath -> String         takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .                             reverse -        dropExeExtension :: FilePath -> FilePath-        dropExeExtension filepath =-          case splitExtension filepath of-            (filepath', extension) | extension == exeExtension -> filepath'-                                   | otherwise                 -> filepath-- -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration                      -> IO InstalledPackageIndex@@ -301,7 +267,7 @@                -> PackageDescription -> LocalBuildInfo                -> Library            -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do-  let libName@(LibraryName cname) = componentLibraryName clbi+  let uid = componentUnitId clbi       libTargetDir = buildDir lbi       whenVanillaLib forceVanilla =         when (not forRepl && (forceVanilla || withVanillaLib lbi))@@ -310,14 +276,13 @@         when (not forRepl &&  (forceShared || withSharedLib lbi))       whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)       ifReplLib = when forRepl-      comp = compiler lbi-      implInfo = getImplInfo comp-      hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n)))-                       (instantiatedWith lbi)+      comp      = compiler lbi+      platform  = hostPlatform lbi+      implInfo  = getImplInfo comp       nativeToo = ghcjsNativeToo comp    (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  let runGhcjsProg        = runGHC verbosity ghcjsProg comp+  let runGhcjsProg        = runGHC verbosity ghcjsProg comp platform       libBi               = libBuildInfo lib       isGhcjsDynamic      = isDynamic comp       dynamicTooSupported = supportsDynamicToo comp@@ -329,10 +294,11 @@   -- Determine if program coverage should be enabled and if so, what   -- '-hpcdir' should be.   let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi+      pkg_name = display $ PD.package $ localPkgDescr lbi       distPref = fromFlag $ configDistPref $ configFlags lbi       hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname-        | otherwise = mempty+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name+        | otherwise = Mon.mempty    createDirectoryIfMissingVerbose verbosity True libTargetDir   -- TODO: do we need to put hs-boot files into place for mutually recursive@@ -342,14 +308,13 @@       baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir       linkJsLibOpts = mempty {                         ghcOptExtra = toNubListR $-                          [ "-link-js-lib"     , getHSLibraryName libName+                          [ "-link-js-lib"     , getHSLibraryName uid                           , "-js-lib-outputdir", libTargetDir ] ++                           concatMap (\x -> ["-js-lib-src",x]) jsSrcs                       }       vanillaOptsNoJsLib = baseOpts `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,                       ghcOptNumJobs      = numJobs,-                      ghcOptSigOf        = hole_insts,                       ghcOptInputModules = toNubListR $ libModules lib,                       ghcOptHPCDir       = hpcdir Hpc.Vanilla                     }@@ -457,11 +422,11 @@                       (cSources libBi)         cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))                       (cSources libBi)-        cid = compilerId (compiler lbi)-        vanillaLibFilePath = libTargetDir </> mkLibName            libName-        profileLibFilePath = libTargetDir </> mkProfLibName        libName-        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid  libName-        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName+        compiler_id = compilerId (compiler lbi)+        vanillaLibFilePath = libTargetDir </> mkLibName            uid+        profileLibFilePath = libTargetDir </> mkProfLibName        uid+        sharedLibFilePath  = libTargetDir </> mkSharedLibName compiler_id uid+        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName uid      hObjs     <- Internal.getHaskellObjects implInfo lib lbi                       libTargetDir objExtension True@@ -499,6 +464,8 @@                 ghcOptDynLinkMode        = toFlag GhcDynamicOnly,                 ghcOptInputFiles         = toNubListR dynamicObjectFiles,                 ghcOptOutputFile         = toFlag sharedLibFilePath,+                ghcOptExtra              = toNubListR $+                                           ghcjsSharedOptions libBi,                 ghcOptNoAutoLinkPackages = toFlag True,                 ghcOptPackageDBs         = withPackageDB lbi,                 ghcOptPackages           = toNubListR $@@ -522,16 +489,16 @@         runGhcjsProg ghcSharedLinkArgs  -- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> Platform                  -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp packageDBs = do+startInterpreter verbosity conf comp platform packageDBs = do   let replOpts = mempty {         ghcOptMode       = toFlag GhcModeInteractive,         ghcOptPackageDBs = packageDBs         }   checkPackageDbStack packageDBs   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf-  runGHC verbosity ghcjsProg comp replOpts+  runGHC verbosity ghcjsProg comp platform replOpts  buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)                   -> PackageDescription -> LocalBuildInfo@@ -547,8 +514,9 @@    (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)   let comp         = compiler lbi+      platform     = hostPlatform lbi       implInfo     = getImplInfo comp-      runGhcjsProg = runGHC verbosity ghcjsProg comp+      runGhcjsProg = runGHC verbosity ghcjsProg comp platform       exeBi        = buildInfo exe    -- exeNameReal, the name that GHC really uses (with .exe on Windows)@@ -755,12 +723,12 @@       findModuleFiles [builtDir] [ext] (libModules lib)       >>= installOrdinaryFiles verbosity targetDir -    cid = compilerId (compiler lbi)-    libName = componentLibraryName clbi-    vanillaLibName = mkLibName              libName-    profileLibName = mkProfLibName          libName-    ghciLibName    = Internal.mkGHCiLibName libName-    sharedLibName  = (mkSharedLibName cid)  libName+    compiler_id = compilerId (compiler lbi)+    uid = componentUnitId clbi+    vanillaLibName = mkLibName              uid+    profileLibName = mkProfLibName          uid+    ghciLibName    = Internal.mkGHCiLibName uid+    sharedLibName  = (mkSharedLibName compiler_id)  uid      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))@@ -800,11 +768,12 @@   let       libBi       = libBuildInfo lib       comp        = compiler lbi+      platform    = hostPlatform lbi       vanillaArgs =         (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))         `mappend` mempty {           ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptInputModules = toNubListR $ exposedModules lib+          ghcOptInputModules = toNubListR $ PD.exposedModules lib         }       profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {                      ghcOptProfilingMode = toFlag True,@@ -815,7 +784,8 @@            else error "libAbiHash: Can't find an enabled library way"   --   (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs)+  getProgramInvocationOutput verbosity+    (ghcInvocation ghcjsProg comp platform ghcArgs)  adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts =@@ -825,16 +795,20 @@   }  registerPackage :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool+                -> ProgramConfiguration+                -> HcPkg.MultiInstance                 -> PackageDBStack+                -> InstalledPackageInfo                 -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs-    (Right installedPkgInfo)+registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo+  | HcPkg.MultiInstance <- multiInstance+  = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity+      packageDbs installedPkgInfo +  | otherwise+  = HcPkg.reregister (hcPkgInfo progdb) verbosity+      packageDbs (Right installedPkgInfo)+ componentGhcOptions :: Verbosity -> LocalBuildInfo                     -> BuildInfo -> ComponentLocalBuildInfo -> FilePath                     -> GhcOptions@@ -874,7 +848,10 @@                                  , HcPkg.noPkgDbStack    = False                                  , HcPkg.noVerboseFlag   = False                                  , HcPkg.flagPackageConf = False-                                 , HcPkg.useSingleFileDb = v < [7,9]+                                 , HcPkg.supportsDirDbs  = True+                                 , HcPkg.requiresDirDbs  = v >= [7,10]+                                 , HcPkg.nativeMultiInstance  = v >= [7,10]+                                 , HcPkg.recacheMultiInstance = True                                  }   where     v                 = versionBranch ver
cabal/Cabal/Distribution/Simple/Haddock.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Haddock@@ -24,76 +26,42 @@ import qualified Distribution.Simple.GHCJS as GHCJS  -- local+import Distribution.Compat.Semigroup as Semi import Distribution.Package-         ( PackageIdentifier(..)-         , Package(..)-         , PackageName(..), packageName, LibraryName(..) ) import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), usedExtensions-         , hcSharedOptions-         , Library(..), hasLibs, Executable(..)-         , TestSuite(..), TestSuiteInterface(..)-         , Benchmark(..), BenchmarkInterface(..) )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, CompilerFlavor(..)-         , compilerFlavor, compilerCompatVersion )+import Distribution.PackageDescription as PD hiding (Flag)+import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Program.GHC-         ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program-         ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion-         , rawSystemProgram, rawSystemProgramStdout-         , hscolourProgram, haddockProgram ) import Distribution.Simple.PreProcess-         ( PPSuffixHandler, preprocessComponent) import Distribution.Simple.Setup-         ( defaultHscolourFlags-         , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag-         , HaddockFlags(..), HscolourFlags(..) )-import Distribution.Simple.Build (initialBuildSteps)+import Distribution.Simple.Build import Distribution.Simple.InstallDirs-         ( InstallDirs(..)-         , PathTemplateEnv, PathTemplate, PathTemplateVariable(..)-         , toPathTemplate, fromPathTemplate-         , substPathTemplate, initialPathTemplateEnv )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-         , withAllComponentsInBuildOrder )+import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) import Distribution.Simple.BuildPaths-         ( haddockName, hscolourPref, autogenModulesDir)-import Distribution.Simple.PackageIndex (dependencyClosure) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo(..) )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )+import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Simple.Utils-         ( die, copyFileTo, warn, notice, intercalate, setupMessage-         , createDirectoryIfMissingVerbose-         , TempFileOptions(..), defaultTempFileOptions-         , withTempFileEx, copyFileVerbose-         , withTempDirectoryEx, matchFileGlob-         , findFileWithExtension, findFile )+import Distribution.System import Distribution.Text-         ( display, simpleParse ) import Distribution.Utils.NubList-         ( toNubListR )-+import Distribution.Version import Distribution.Verbosity import Language.Haskell.Extension   import Control.Monad    ( when, forM_ )+import Data.Char        ( isSpace ) import Data.Either      ( rights )-import Data.Foldable    ( traverse_ )-import Data.Monoid+import Data.Foldable    ( traverse_, foldl' ) import Data.Maybe       ( fromMaybe, listToMaybe )+import GHC.Generics     ( Generic )  import System.Directory (doesFileExist) import System.FilePath  ( (</>), (<.>)                         , normalise, splitPath, joinPath, isAbsolute )-import System.IO        (hClose, hPutStrLn, hSetEncoding, utf8)-import Distribution.Version+import System.IO        (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8)  -- ------------------------------------------------------------------------------ -- Types@@ -132,7 +100,7 @@  -- ^ To find the correct GHC, required.  argTargets :: [FilePath]  -- ^ Modules to process.-}+} deriving Generic  -- | The FilePath of a directory, it's a monoid under '(</>)'. newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)@@ -162,7 +130,28 @@         ++ "a library. Perhaps you want to use the --executables, --tests or"         ++ " --benchmarks flags." -haddock pkg_descr lbi suffixes flags = do+haddock pkg_descr lbi suffixes flags' = do+    let verbosity     = flag haddockVerbosity+        comp          = compiler lbi+        platform      = hostPlatform lbi++        flags+          | fromFlag (haddockForHackage flags') = flags'+            { haddockHoogle       = Flag True+            , haddockHtml         = Flag True+            , haddockHtmlLocation = Flag (pkg_url ++ "/docs")+            , haddockContents     = Flag (toPathTemplate pkg_url)+            , haddockHscolour     = Flag True+            }+          | otherwise = flags'+        pkg_url       = "/package/$pkg-$version"+        flag f        = fromFlag $ f flags++        tmpFileOpts   = defaultTempFileOptions+                       { optKeepTempFiles = flag haddockKeepTempFiles }+        htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation+                        $ flags+     setupMessage verbosity "Running Haddock for" (packageId pkg_descr)     (confHaddock, version, _) <-       requireProgramVersion verbosity haddockProgram@@ -188,8 +177,6 @@      -- the tools match the requests, we can proceed -    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity-     when (flag haddockHscolour) $       hscolour' (warn verbosity) pkg_descr lbi suffixes       (defaultHscolourFlags `mappend` haddockToHscolour flags)@@ -198,11 +185,12 @@     let commonArgs = mconcat             [ libdirArgs             , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags-            , fromPackageDescription pkg_descr ]+            , fromPackageDescription forDist pkg_descr ]+        forDist = fromFlagOrDefault False (haddockForHackage flags) -    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes     withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do-      pre component+      initialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity+      preprocessComponent pkg_descr component lbi clbi False verbosity suffixes       let         doExe com = case (compToExe com) of           Just exe -> do@@ -211,7 +199,8 @@                 exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate                            version                 let exeArgs' = commonArgs `mappend` exeArgs-                runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'+                runHaddock verbosity tmpFileOpts comp platform+                  confHaddock exeArgs'           Nothing -> do            warn (fromFlag $ haddockVerbosity flags)              "Unsupported component, skipping..."@@ -223,7 +212,7 @@               libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate                          version               let libArgs' = commonArgs `mappend` libArgs-              runHaddock verbosity tmpFileOpts comp confHaddock libArgs'+              runHaddock verbosity tmpFileOpts comp platform confHaddock libArgs'         CExe   _ -> when (flag haddockExecutables) $ doExe component         CTest  _ -> when (flag haddockTestSuites)  $ doExe component         CBench _ -> when (flag haddockBenchmarks)  $ doExe component@@ -231,14 +220,6 @@     forM_ (extraDocFiles pkg_descr) $ \ fpath -> do       files <- matchFileGlob fpath       forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)-  where-    verbosity     = flag haddockVerbosity-    keepTempFiles = flag haddockKeepTempFiles-    comp          = compiler lbi-    tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }-    flag f        = fromFlag $ f flags-    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation-                    $ flags  -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs.@@ -266,12 +247,11 @@       argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags     } -fromPackageDescription :: PackageDescription -> HaddockArgs-fromPackageDescription pkg_descr =+fromPackageDescription :: Bool -> PackageDescription -> HaddockArgs+fromPackageDescription forDist pkg_descr =       mempty { argInterfaceFile = Flag $ haddockName pkg_descr,                argPackageName = Flag $ packageId $ pkg_descr,-               argOutputDir = Dir $ "doc" </> "html"-                              </> display (packageName pkg_descr),+               argOutputDir = Dir $ "doc" </> "html" </> name,                argPrologue = Flag $ if null desc then synopsis pkg_descr                                     else desc,                argTitle = Flag $ showPkg ++ subtitle@@ -279,6 +259,9 @@       where         desc = PD.description pkg_descr         showPkg = display (packageId pkg_descr)+        name+          | forDist = showPkg ++ "-docs"+          | otherwise = display (packageName pkg_descr)         subtitle | null (synopsis pkg_descr) = ""                  | otherwise                 = ": " ++ synopsis pkg_descr @@ -301,7 +284,7 @@             -> Version             -> IO HaddockArgs fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do-    inFiles <- map snd `fmap` getLibSourceFiles lbi lib+    inFiles <- map snd `fmap` getLibSourceFiles lbi lib clbi     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {                           -- Noooooooooo!!!!!111@@ -346,7 +329,7 @@                -> Version                -> IO HaddockArgs fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do-    inFiles <- map snd `fmap` getExeSourceFiles lbi exe+    inFiles <- map snd `fmap` getExeSourceFiles lbi exe clbi     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate     let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {                           -- Noooooooooo!!!!!111@@ -444,13 +427,14 @@ runHaddock :: Verbosity               -> TempFileOptions               -> Compiler+              -> Platform               -> ConfiguredProgram               -> HaddockArgs               -> IO ()-runHaddock verbosity tmpFileOpts comp confHaddock args = do+runHaddock verbosity tmpFileOpts comp platform confHaddock args = do   let haddockVersion = fromMaybe (error "unable to determine haddock version")                        (programVersion confHaddock)-  renderArgs verbosity tmpFileOpts haddockVersion comp args $+  renderArgs verbosity tmpFileOpts haddockVersion comp platform args $     \(flags,result)-> do        rawSystemProgram verbosity confHaddock flags@@ -462,12 +446,13 @@               -> TempFileOptions               -> Version               -> Compiler+              -> Platform               -> HaddockArgs               -> (([String], FilePath) -> IO a)               -> IO a-renderArgs verbosity tmpFileOpts version comp args k = do+renderArgs verbosity tmpFileOpts version comp platform args k = do   let haddockSupportsUTF8          = version >= Version [2,14,4] []-      haddockSupportsResponseFiles = version >  Version [2,16,1] []+      haddockSupportsResponseFiles = version >  Version [2,16,2] []   createDirectoryIfMissingVerbose verbosity True outputDir   withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $     \prologueFileName h -> do@@ -476,13 +461,13 @@              hPutStrLn h $ fromFlag $ argPrologue args              hClose h              let pflag = "--prologue=" ++ prologueFileName-                 renderedArgs = pflag : renderPureArgs version comp args-             if haddockSupportsResponseFiles +                 renderedArgs = pflag : renderPureArgs version comp platform args+             if haddockSupportsResponseFiles                then                  withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $                     \responseFileName hf -> do                          when haddockSupportsUTF8 (hSetEncoding hf utf8)-                         mapM_ (hPutStrLn hf) renderedArgs+                         hPutStr hf $ unlines $ map escapeArg renderedArgs                          hClose hf                          let respFile = "@" ++ responseFileName                          k ([respFile], result)@@ -500,9 +485,22 @@               pkgstr = display $ packageName pkgid               pkgid = arg argPackageName       arg f = fromFlag $ f args+      -- Support a gcc-like response file syntax.  Each separate+      -- argument and its possible parameter(s), will be separated in the+      -- response file by an actual newline; all other whitespace,+      -- single quotes, double quotes, and the character used for escaping+      -- (backslash) are escaped.  The called program will need to do a similar+      -- inverse operation to de-escape and re-constitute the argument list.+      escape cs c+        |    isSpace c+          || '\\' == c+          || '\'' == c+          || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result+        | otherwise    = c:cs+      escapeArg = reverse . foldl' escape [] -renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]-renderPureArgs version comp args = concat+renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]+renderPureArgs version comp platform args = concat     [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)       . fromFlag . argInterfaceFile $ args @@ -544,7 +542,7 @@       . fromFlag . argTitle $ args      , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)-                           , opt <- renderGhcOptions comp opts ]+                           , opt <- renderGhcOptions comp platform opts ]      , maybe [] (\l -> ["-B"++l]) $       flagToMaybe (argGhcLibDir args) -- error if Nothing?@@ -616,7 +614,7 @@ haddockPackageFlags lbi clbi htmlTemplate = do   let allPkgs = installedPkgs lbi       directDeps = map fst (componentPackageDeps clbi)-  transitiveDeps <- case dependencyClosure allPkgs directDeps of+  transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of     Left x    -> return x     Right inf -> die $ "internal error when calculating transitive "                     ++ "package dependencies.\nDebug info: " ++ show inf@@ -631,7 +629,9 @@ haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id =   (PrefixVar, prefix (installDirTemplates lbi))-  : initialPathTemplateEnv pkg_id (LibraryName (display pkg_id)) (compilerInfo (compiler lbi))+  -- We want the legacy unit ID here, because it gives us nice paths+  -- (Haddock people don't care about the dependencies)+  : initialPathTemplateEnv pkg_id (mkLegacyUnitId pkg_id) (compilerInfo (compiler lbi))   (hostPlatform lbi)  -- ------------------------------------------------------------------------------@@ -643,13 +643,7 @@          -> HscolourFlags          -> IO () hscolour pkg_descr lbi suffixes flags = do-  -- we preprocess even if hscolour won't be found on the machine-  -- will this upset someone?-  initialBuildSteps distPref pkg_descr lbi verbosity   hscolour' die pkg_descr lbi suffixes flags- where-   verbosity  = fromFlag (hscolourVerbosity flags)-   distPref = fromFlag $ hscolourDistPref flags  hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.           -> PackageDescription@@ -668,15 +662,15 @@       createDirectoryIfMissingVerbose verbosity True $         hscolourPref distPref pkg_descr -      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-      withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do-        pre comp+      withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do+        initialBuildSteps distPref pkg_descr lbi clbi verbosity+        preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes         let           doExe com = case (compToExe com) of             Just exe -> do               let outputDir = hscolourPref distPref pkg_descr                               </> exeName exe </> "src"-              runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+              runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe clbi             Nothing -> do               warn (fromFlag $ hscolourVerbosity flags)                 "Unsupported component, skipping..."@@ -684,7 +678,7 @@         case comp of           CLib lib -> do             let outputDir = hscolourPref distPref pkg_descr </> "src"-            runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib+            runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib clbi           CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp           CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp           CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp@@ -726,24 +720,26 @@  getLibSourceFiles :: LocalBuildInfo                      -> Library+                     -> ComponentLocalBuildInfo                      -> IO [(ModuleName.ModuleName, FilePath)]-getLibSourceFiles lbi lib = getSourceFiles searchpaths modules+getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules   where     bi               = libBuildInfo lib     modules          = PD.exposedModules lib ++ otherModules bi-    searchpaths      = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi+    searchpaths      = autogenModulesDir lbi clbi : buildDir lbi : hsSourceDirs bi  getExeSourceFiles :: LocalBuildInfo                      -> Executable+                     -> ComponentLocalBuildInfo                      -> IO [(ModuleName.ModuleName, FilePath)]-getExeSourceFiles lbi exe = do+getExeSourceFiles lbi exe clbi = do     moduleFiles <- getSourceFiles searchpaths modules     srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)     return ((ModuleName.main, srcMainPath) : moduleFiles)   where     bi          = buildInfo exe     modules     = otherModules bi-    searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi+    searchpaths = autogenModulesDir lbi clbi : exeBuildDir lbi exe : hsSourceDirs bi  getSourceFiles :: [FilePath]                   -> [ModuleName.ModuleName]@@ -761,44 +757,15 @@ -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. instance Monoid HaddockArgs where-    mempty = HaddockArgs {-                argInterfaceFile = mempty,-                argPackageName = mempty,-                argHideModules = mempty,-                argIgnoreExports = mempty,-                argLinkSource = mempty,-                argCssFile = mempty,-                argContents = mempty,-                argVerbose = mempty,-                argOutput = mempty,-                argInterfaces = mempty,-                argOutputDir = mempty,-                argTitle = mempty,-                argPrologue = mempty,-                argGhcOptions = mempty,-                argGhcLibDir = mempty,-                argTargets = mempty-             }-    mappend a b = HaddockArgs {-                argInterfaceFile = mult argInterfaceFile,-                argPackageName = mult argPackageName,-                argHideModules = mult argHideModules,-                argIgnoreExports = mult argIgnoreExports,-                argLinkSource = mult argLinkSource,-                argCssFile = mult argCssFile,-                argContents = mult argContents,-                argVerbose = mult argVerbose,-                argOutput = mult argOutput,-                argInterfaces = mult argInterfaces,-                argOutputDir = mult argOutputDir,-                argTitle = mult argTitle,-                argPrologue = mult argPrologue,-                argGhcOptions = mult argGhcOptions,-                argGhcLibDir = mult argGhcLibDir,-                argTargets = mult argTargets-             }-      where mult f = f a `mappend` f b+    mempty = gmempty+    mappend = (Semi.<>) +instance Semigroup HaddockArgs where+    (<>) = gmappend+ instance Monoid Directory where     mempty = Dir "."-    mappend (Dir m) (Dir n) = Dir $ m </> n+    mappend = (Semi.<>)++instance Semigroup Directory where+    Dir m <> Dir n = Dir $ m </> n
cabal/Cabal/Distribution/Simple/HaskellSuite.hs view
@@ -1,10 +1,6 @@-{-# LANGUAGE CPP #-} module Distribution.Simple.HaskellSuite where  import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif import Data.Maybe import Data.Version import qualified Data.Map as M (empty)@@ -24,7 +20,6 @@ import Distribution.Compat.Exception import Language.Haskell.Extension import Distribution.Simple.Program.Builtin-  (haskellSuiteProgram, haskellSuitePkgProgram)  configure   :: Verbosity -> Maybe FilePath -> Maybe FilePath@@ -60,7 +55,7 @@       let         haskellSuiteProgram' =           haskellSuiteProgram-            { programFindLocation = \v _p -> findProgramLocation v hcPath }+            { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath }        -- NB: cannot call requireProgram right away — it'd think that       -- the program is already configured and won't reconfigure it again.@@ -106,7 +101,7 @@ getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)] getExtensions verbosity prog = do   extStrs <--    lines <$>+    lines `fmap`     rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]   return     [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ]@@ -114,7 +109,7 @@ getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)] getLanguages verbosity prog = do   langStrs <--    lines <$>+    lines `fmap`     rawSystemStdout verbosity (programPath prog) ["--supported-languages"]   return     [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ]@@ -170,7 +165,7 @@   runDbProgram verbosity haskellSuiteProgram conf $     [ "compile", "--build-dir", odir ] ++     concat [ ["-i", d] | d <- srcDirs ] ++-    concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] +++    concat [ ["-I", d] | d <- [autogenModulesDir lbi clbi, odir] ++ includeDirs bi ] ++     [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++     [ "--package-name", display pkgid ] ++     concat [ ["--package-id", display ipkgid ]@@ -190,8 +185,9 @@   -> FilePath  -- ^Build location   -> PackageDescription   -> Library+  -> ComponentLocalBuildInfo   -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib _clbi = do   let conf = withPrograms lbi   runDbProgram verbosity haskellSuitePkgProgram conf $     [ "install-library"@@ -203,14 +199,12 @@  registerPackage   :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool+  -> ProgramConfiguration   -> PackageDBStack+  -> InstalledPackageInfo   -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi)+registerPackage verbosity progdb packageDbs installedPkgInfo = do+  (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb    runProgramInvocation verbosity $     (programInvocation hspkg
cabal/Cabal/Distribution/Simple/Install.hs view
@@ -16,13 +16,9 @@         install,   ) where -import Distribution.PackageDescription (-        PackageDescription(..), BuildInfo(..), Library(..),-        hasLibs, withLib, hasExes, withExe )+import Distribution.PackageDescription import Distribution.Package (Package(..))-import Distribution.Simple.LocalBuildInfo (-        LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,-        substPathTemplate, withLibLBI)+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose@@ -31,6 +27,7 @@ import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup (CopyFlags(..), fromFlag)+import Distribution.Simple.BuildTarget  import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS@@ -51,6 +48,9 @@  -- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" -- actions.  Move files into place based on the prefix argument.+--+-- This does NOT register libraries, you should call 'register'+-- to do that.  install :: PackageDescription -- ^information from the .cabal file         -> LocalBuildInfo -- ^information from the configure step@@ -60,33 +60,41 @@   let distPref  = fromFlag (copyDistPref flags)       verbosity = fromFlag (copyVerbosity flags)       copydest  = fromFlag (copyDest flags)-      installDirs@(InstallDirs {-         bindir     = binPref,-         libdir     = libPref,---         dynlibdir  = dynlibPref, --see TODO below+      -- This is a bit of a hack, to handle files which are not+      -- per-component (data files and Haddock files.)+      InstallDirs {          datadir    = dataPref,+         -- NB: The situation with Haddock is a bit delicate.  On the+         -- one hand, the easiest to understand Haddock documentation+         -- path is pkgname-0.1, which means it's per-package (not+         -- per-component).  But this means that it's impossible to+         -- install Haddock documentation for internal libraries.  We'll+         -- keep this constraint for now; this means you can't use+         -- Cabal to Haddock internal libraries.  This does not seem+         -- like a big problem.          docdir     = docPref,          htmldir    = htmlPref,-         haddockdir = interfacePref,-         includedir = incPref})+         haddockdir = interfacePref}+             -- Notice use of 'absoluteInstallDirs' (not the+             -- per-component variant).  This means for non-library+             -- packages we'll just pick a nondescriptive foo-0.1              = absoluteInstallDirs pkg_descr lbi copydest -      --TODO: decide if we need the user to be able to control the libdir-      -- for shared libs independently of the one for static libs. If so-      -- it should also have a flag in the command line UI-      -- For the moment use dynlibdir = libdir-      dynlibPref = libPref-      progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi)-      progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi)-   unless (hasLibs pkg_descr || hasExes pkg_descr) $       die "No executables and no library found. Nothing to do."++  targets <- readBuildTargets pkg_descr (copyArgs flags)+  targets' <- checkBuildTargets verbosity pkg_descr targets++  -- Install (package-global) data files+  installDataFiles verbosity pkg_descr dataPref++  -- Install (package-global) Haddock files+  -- TODO: these should be done per-library   docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr   info verbosity ("directory " ++ haddockPref distPref pkg_descr ++                   " does exist: " ++ show docExists) -  installDataFiles verbosity pkg_descr dataPref-   when docExists $ do       createDirectoryIfMissingVerbose verbosity True htmlPref       installDirectoryContents verbosity@@ -114,45 +122,74 @@       [ installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)       | lfile <- lfiles ] -  let buildPref = buildDir lbi-  when (hasLibs pkg_descr) $-    notice verbosity ("Installing library in " ++ libPref)-  when (hasExes pkg_descr) $ do-    notice verbosity ("Installing executable(s) in " ++ binPref)+  -- It's not necessary to do these in build-order, but it's harmless+  withComponentsInBuildOrder pkg_descr lbi (map fst targets') $ \comp clbi ->+    copyComponent verbosity pkg_descr lbi comp clbi copydest++copyComponent :: Verbosity -> PackageDescription+              -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo+              -> CopyDest+              -> IO ()+copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do+    let InstallDirs{+            libdir = libPref,+            includedir = incPref+            } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest+        buildPref = componentBuildDir lbi clbi+    -- TODO: decide if we need the user to be able to control the libdir+    -- for shared libs independently of the one for static libs. If so+    -- it should also have a flag in the command line UI+    -- For the moment use dynlibdir = libdir+        dynlibPref = libPref++    if componentUnitId clbi == localUnitId lbi+        then notice verbosity ("Installing library in " ++ libPref)+        else notice verbosity ("Installing internal library " ++ libName lib ++ " in " ++ libPref)++    -- install include files for all compilers - they may be needed to compile+    -- haskell files (using the CPP extension)+    installIncludeFiles verbosity lib incPref++    case compilerFlavor (compiler lbi) of+      GHC   -> GHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      LHC   -> LHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      JHC   -> JHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      UHC   -> UHC.installLib   verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      HaskellSuite _ -> HaskellSuite.installLib+                                verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi+      _ -> die $ "installing with "+              ++ display (compilerFlavor (compiler lbi))+              ++ " is not implemented"++copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do+    let installDirs@InstallDirs {+            bindir = binPref+            } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest+        -- the installers know how to find the actual location of the+        -- binaries+        buildPref = buildDir lbi+        uid = componentUnitId clbi+        progPrefixPref = substPathTemplate (packageId pkg_descr) lbi uid (progPrefix lbi)+        progSuffixPref = substPathTemplate (packageId pkg_descr) lbi uid (progSuffix lbi)+    notice verbosity ("Installing executable " ++ exeName exe ++ " in " ++ binPref)     inPath <- isInSearchPath binPref     when (not inPath) $       warn verbosity ("The directory " ++ binPref                       ++ " is not in the system search path.")--  -- install include files for all compilers - they may be needed to compile-  -- haskell files (using the CPP extension)-  when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref+    case compilerFlavor (compiler lbi) of+      GHC   -> GHC.installExe   verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe+      GHCJS -> GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe+      LHC   -> LHC.installExe   verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe+      JHC   -> JHC.installExe   verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr exe+      UHC   -> return ()+      HaskellSuite {} -> return ()+      _ -> die $ "installing with "+              ++ display (compilerFlavor (compiler lbi))+              ++ " is not implemented" -  case compilerFlavor (compiler lbi) of-     GHC  -> do withLibLBI pkg_descr lbi $-                  GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     GHCJS-> do withLibLBI pkg_descr lbi $-                  GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     LHC  -> do withLibLBI pkg_descr lbi $-                  LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     JHC  -> do withLib pkg_descr $-                  JHC.installLib verbosity libPref buildPref pkg_descr-                withExe pkg_descr $-                  JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr-     UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-     HaskellSuite {} ->-       withLib pkg_descr $-         HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-     _    -> die $ "installing with "-                ++ display (compilerFlavor (compiler lbi))-                ++ " is not implemented"-  -- register step should be performed by caller.+-- Nothing to do for benchmark/testsuite+copyComponent _ _ _ _ _ _ = return ()  -- | Install the files listed in data-files --@@ -167,26 +204,23 @@                                               (destDataDir </> file')               | file' <- files ] --- | Install the files listed in install-includes+-- | Install the files listed in install-includes for a library ---installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()-installIncludeFiles verbosity-  PackageDescription { library = Just lib } destIncludeDir = do--  incs <- mapM (findInc relincdirs) (installIncludes lbi)-  sequence_-    [ do createDirectoryIfMissingVerbose verbosity True destDir-         installOrdinaryFile verbosity srcFile destFile-    | (relFile, srcFile) <- incs-    , let destFile = destIncludeDir </> relFile-          destDir  = takeDirectory destFile ]+installIncludeFiles :: Verbosity -> Library -> FilePath -> IO ()+installIncludeFiles verbosity lib destIncludeDir = do+    let relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)+        lbi = libBuildInfo lib+    incs <- mapM (findInc relincdirs) (installIncludes lbi)+    sequence_+      [ do createDirectoryIfMissingVerbose verbosity True destDir+           installOrdinaryFile verbosity srcFile destFile+      | (relFile, srcFile) <- incs+      , let destFile = destIncludeDir </> relFile+            destDir  = takeDirectory destFile ]   where-   relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-   lbi = libBuildInfo lib     findInc []         file = die ("can't find include file " ++ file)    findInc (dir:dirs) file = do      let path = dir </> file      exists <- doesFileExist path      if exists then return (file, path) else findInc dirs file-installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?"
cabal/Cabal/Distribution/Simple/InstallDirs.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}  -----------------------------------------------------------------------------@@ -46,25 +47,19 @@   import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Semigroup as Semi+import Distribution.Package+import Distribution.System+import Distribution.Compiler+import Distribution.Text+ import Data.List (isPrefixOf) import Data.Maybe (fromMaybe)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif import GHC.Generics (Generic) import System.Directory (getAppUserDataDirectory) import System.FilePath ((</>), isPathSeparator, pathSeparator) import System.FilePath (dropDrive) -import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion, LibraryName )-import Distribution.System-         ( OS(..), buildOS, Platform(..) )-import Distribution.Compiler-         ( AbiTag(..), abiTagString, CompilerInfo(..), CompilerFlavor(..) )-import Distribution.Text-         ( display )- #if mingw32_HOST_OS import Foreign import Foreign.C@@ -96,46 +91,16 @@         htmldir      :: dir,         haddockdir   :: dir,         sysconfdir   :: dir-    } deriving (Generic, Read, Show)+    } deriving (Eq, Read, Show, Functor, Generic)  instance Binary dir => Binary (InstallDirs dir) -instance Functor InstallDirs where-  fmap f dirs = InstallDirs {-    prefix       = f (prefix dirs),-    bindir       = f (bindir dirs),-    libdir       = f (libdir dirs),-    libsubdir    = f (libsubdir dirs),-    dynlibdir    = f (dynlibdir dirs),-    libexecdir   = f (libexecdir dirs),-    includedir   = f (includedir dirs),-    datadir      = f (datadir dirs),-    datasubdir   = f (datasubdir dirs),-    docdir       = f (docdir dirs),-    mandir       = f (mandir dirs),-    htmldir      = f (htmldir dirs),-    haddockdir   = f (haddockdir dirs),-    sysconfdir   = f (sysconfdir dirs)-  }+instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where+  mempty = gmempty+  mappend = (Semi.<>) -instance Monoid dir => Monoid (InstallDirs dir) where-  mempty = InstallDirs {-      prefix       = mempty,-      bindir       = mempty,-      libdir       = mempty,-      libsubdir    = mempty,-      dynlibdir    = mempty,-      libexecdir   = mempty,-      includedir   = mempty,-      datadir      = mempty,-      datasubdir   = mempty,-      docdir       = mempty,-      mandir       = mempty,-      htmldir      = mempty,-      haddockdir   = mempty,-      sysconfdir   = mempty-  }-  mappend = combineInstallDirs mappend+instance Semigroup dir => Semigroup (InstallDirs dir) where+  (<>) = gmappend  combineInstallDirs :: (a -> b -> c)                    -> InstallDirs a@@ -287,7 +252,7 @@ -- substituting for all the variables in the abstract paths, to get real -- absolute path. absoluteInstallDirs :: PackageIdentifier-                    -> LibraryName+                    -> UnitId                     -> CompilerInfo                     -> CopyDest                     -> Platform@@ -317,7 +282,7 @@ -- independent\" package). -- prefixRelativeInstallDirs :: PackageIdentifier-                          -> LibraryName+                          -> UnitId                           -> CompilerInfo                           -> Platform                           -> InstallDirTemplates@@ -349,7 +314,8 @@ -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. ---newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Generic, Ord)+newtype PathTemplate = PathTemplate [PathComponent]+  deriving (Eq, Ord, Generic)  instance Binary PathTemplate @@ -372,7 +338,7 @@      | PkgNameVar    -- ^ The @$pkg@ package name path variable      | PkgVerVar     -- ^ The @$version@ package version path variable      | PkgIdVar      -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@-     | LibNameVar    -- ^ The @$libname@ expanded package key path variable+     | LibNameVar    -- ^ The @$libname@ path variable      | CompilerVar   -- ^ The compiler name and version, eg @ghc-6.6.1@      | OSVar         -- ^ The operating system name, eg @windows@ or @linux@      | ArchVar       -- ^ The CPU architecture name, eg @i386@ or @x86_64@@@ -415,7 +381,7 @@  -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier-                       -> LibraryName+                       -> UnitId                        -> CompilerInfo                        -> Platform                        -> PathTemplateEnv@@ -425,7 +391,7 @@   ++ platformTemplateEnv platform   ++ abiTemplateEnv compiler platform -packageTemplateEnv :: PackageIdentifier -> LibraryName -> PathTemplateEnv+packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId libname =   [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])   ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])@@ -478,7 +444,7 @@  instance Show PathTemplateVariable where   show PrefixVar     = "prefix"-  show LibNameVar     = "libname"+  show LibNameVar    = "libname"   show BindirVar     = "bindir"   show LibdirVar     = "libdir"   show LibsubdirVar  = "libsubdir"@@ -515,8 +481,8 @@                  ,("docdir",     DocdirVar)                  ,("htmldir",    HtmldirVar)                  ,("pkgid",      PkgIdVar)-                 ,("pkgkey",     LibNameVar) -- backwards compatibility                  ,("libname",    LibNameVar)+                 ,("pkgkey",     LibNameVar) -- backwards compatibility                  ,("pkg",        PkgNameVar)                  ,("version",    PkgVerVar)                  ,("compiler",   CompilerVar)
cabal/Cabal/Distribution/Simple/JHC.hs view
@@ -16,40 +16,23 @@         installLib, installExe  ) where -import Distribution.PackageDescription as PD-       ( PackageDescription(..), BuildInfo(..), Executable(..)-       , Library(..), libModules, hcOptions, usedExtensions )+import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo-         ( emptyInstalledPackageInfo, ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) import Distribution.Simple.BuildPaths-                                ( autogenModulesDir, exeExtension ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), AbiTag(..)-         , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..)) import Distribution.Simple.Program-         ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration-         , userMaybeSpecifyPath, requireProgramVersion, lookupProgram-         , rawSystemProgram, rawSystemProgramStdoutConf ) import Distribution.Version-         ( Version(..), orLaterVersion ) import Distribution.Package-         ( Package(..), InstalledPackageId(InstalledPackageId),-           pkgName, pkgVersion, ) import Distribution.Simple.Utils-        ( createDirectoryIfMissingVerbose, writeFileAtomic-        , installOrdinaryFile, installExecutableFile-        , intercalate )-import System.FilePath          ( (</>) ) import Distribution.Verbosity import Distribution.Text-         ( Text(parse), display )++import System.FilePath          ( (</>) ) import Distribution.Compat.ReadP     ( readP_to_S, string, skipSpaces ) import Distribution.System ( Platform )@@ -57,7 +40,6 @@ import Data.List                ( nub ) import Data.Char                ( isSpace ) import qualified Data.Map as M  ( empty )-import Data.Maybe               ( fromMaybe )  import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -116,8 +98,7 @@    return $       PackageIndex.fromList $       map (\p -> emptyInstalledPackageInfo {-                    InstalledPackageInfo.installedPackageId =-                       InstalledPackageId (display p),+                    InstalledPackageInfo.installedUnitId = mkLegacyUnitId p,                     InstalledPackageInfo.sourcePackageId = p                  }) $       concatMap parseLine $@@ -162,7 +143,7 @@      ++ extensionsToFlags (compiler lbi) (usedExtensions bi)      ++ ["--noauto","-i-"]      ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)]-     ++ ["-i", autogenModulesDir lbi]+     ++ ["-i", autogenModulesDir lbi clbi]      ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]      -- It would be better if JHC would accept package names with versions,      -- but JHC-0.7.2 doesn't accept this.@@ -173,7 +154,10 @@ jhcPkgConf :: PackageDescription -> String jhcPkgConf pd =   let sline name sel = name ++ ": "++sel pd-      lib = fromMaybe (error "no library available") . library+      lib pd' = case libraries pd' of+                [lib'] -> lib'+                [] -> error "no library available"+                _ -> error "JHC does not support multiple libraries (yet)"       comma = intercalate "," . map display   in unlines [sline "name" (display . pkgName . packageId)              ,sline "version" (display . pkgVersion . packageId)@@ -181,8 +165,16 @@              ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib)              ] -installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO ()-installLib verb dest build_dir pkg_descr _ = do+installLib :: Verbosity+           -> LocalBuildInfo+           -> FilePath+           -> FilePath+           -> FilePath+           -> PackageDescription+           -> Library+           -> ComponentLocalBuildInfo+           -> IO ()+installLib verb _lbi dest _dyn_dest build_dir pkg_descr _lib _clbi = do     let p = display (packageId pkg_descr)++".hl"     createDirectoryIfMissingVerbose verb True dest     installOrdinaryFile verb (build_dir </> p) (dest </> p)
cabal/Cabal/Distribution/Simple/LHC.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.LHC@@ -41,66 +40,37 @@         ghcVerbosityOptions  ) where -import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions-         , usedExtensions, allExtensions )+import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo-                                ( InstalledPackageInfo-                                , parseInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo(..) ) import Distribution.Simple.PackageIndex import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.ParseUtils  ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )-import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( Package(..), LibraryName, getHSLibraryName ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath, ProgramLocation(..)-         , rawSystemProgram, rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , requireProgramVersion-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , arProgram, ldProgram-         , gccProgram, stripProgram-         , lhcProgram, lhcPkgProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..)-         , Flag, languageToFlags, extensionsToFlags ) import Distribution.Version-         ( Version(..), orLaterVersion )-import Distribution.System-         ( OS(..), buildOS ) import Distribution.Verbosity import Distribution.Text-         ( display, simpleParse )+import Distribution.Compat.Exception+import Distribution.System import Language.Haskell.Extension-         ( Language(Haskell98), Extension(..), KnownExtension(..) )  import Control.Monad            ( unless, when )+import Data.Monoid as Mon import Data.List import qualified Data.Map as M  ( empty ) import Data.Maybe               ( catMaybes )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif import System.Directory         ( removeFile, renameFile,                                   getDirectoryContents, doesFileExist,                                   getTemporaryDirectory ) import System.FilePath          ( (</>), (<.>), takeExtension,                                   takeDirectory, replaceExtension ) import System.IO (hClose, hPutStrLn)-import Distribution.Compat.Exception (catchExit, catchIO)-import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring@@ -149,22 +119,23 @@       programPostConf     = configureGcc     }   . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram (libDir </> "ld.exe"),+      programFindLocation = findProg ldProgram (gccLibDir </> "ld.exe"),       programPostConf     = configureLd     }   where     compilerDir = takeDirectory (programPath lhcProg)     baseDir     = takeDirectory compilerDir-    libDir      = baseDir </> "gcc-lib"+    gccLibDir      = baseDir </> "gcc-lib"     includeDir  = baseDir </> "include" </> "mingw"     isWindows   = case buildOS of Windows -> True; _ -> False      -- on Windows finding and configuring ghc's gcc and ld is a bit special     findProg :: Program -> FilePath-             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+             -> Verbosity -> ProgramSearchPath+             -> IO (Maybe (FilePath, [FilePath]))     findProg prog location | isWindows = \verbosity searchpath -> do         exists <- doesFileExist location-        if exists then return (Just location)+        if exists then return (Just (location, []))                   else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")                           programFindLocation prog verbosity searchpath       | otherwise = programFindLocation prog@@ -177,7 +148,7 @@           -- that means we should add this extra flag to tell ghc's gcc           -- where it lives and thus where gcc can find its various files:           FoundOnSystem {} -> return gccProg {-                                programDefaultArgs = ["-B" ++ libDir,+                                programDefaultArgs = ["-B" ++ gccLibDir,                                                       "-I" ++ includeDir]                               }           UserSpecified {} -> return gccProg@@ -230,7 +201,7 @@   pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf   let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)                 | (_, pkgs) <- pkgss ]-  return $! (mconcat indexes)+  return $! (Mon.mconcat indexes)    where     -- On Windows, various fields have $topdir/foo rather than full@@ -318,8 +289,8 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do-  let libName = componentLibraryName clbi-      pref = buildDir lbi+  let lib_name = componentUnitId clbi+      pref = componentBuildDir lbi clbi       pkgid = packageId pkg_descr       runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)       ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)@@ -373,10 +344,10 @@   let cObjs = map (`replaceExtension` objExtension) (cSources libBi)       cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)       cid = compilerId (compiler lbi)-      vanillaLibFilePath = libTargetDir </> mkLibName           libName-      profileLibFilePath = libTargetDir </> mkProfLibName       libName-      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName+      vanillaLibFilePath = libTargetDir </> mkLibName           lib_name+      profileLibFilePath = libTargetDir </> mkProfLibName       lib_name+      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid lib_name+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       lib_name    stubObjs <- fmap catMaybes $ sequence     [ findFileWithExtension [objExtension] [libTargetDir]@@ -455,7 +426,7 @@             -- This method is called iteratively by xargs. The             -- output goes to <ldLibName>.tmp, and any existing file             -- named <ldLibName> is included when linking. The-            -- output is renamed to <libName>.+            -- output is renamed to <lib_name>.           rawSystemProgramConf verbosity ldProgram (withPrograms lbi)             (args ++ if exists then [ldLibName] else [])           renameFile (ldLibName <.> "tmp") ldLibName@@ -525,7 +496,7 @@           ++ [srcMainFile]           ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi]           ++ ["-l"++lib | lib <- extraLibs exeBi]-          ++ ["-L"++libDir | libDir <- extraLibDirs exeBi]+          ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs exeBi]           ++ concat [["-framework", f] | f <- PD.frameworks exeBi]           ++ if profExe                 then ["-prof",@@ -607,12 +578,12 @@      ++ ["-i"]      ++ ["-i" ++ odir]      ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-     ++ ["-i" ++ autogenModulesDir lbi]-     ++ ["-I" ++ autogenModulesDir lbi]+     ++ ["-i" ++ autogenModulesDir lbi clbi]+     ++ ["-I" ++ autogenModulesDir lbi clbi]      ++ ["-I" ++ odir]      ++ ["-I" ++ dir | dir <- PD.includeDirs bi]      ++ ["-optP" ++ opt | opt <- cppOptions bi]-     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]+     ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi clbi </> cppHeaderName) ]      ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ]      ++ [ "-odir",  odir, "-hidir", odir ]      ++ (if compilerVersion c >= Version [6,8] []@@ -682,7 +653,7 @@            _              -> ["-optc-O2"])      ++ ["-odir", odir] -mkGHCiLibName :: LibraryName -> String+mkGHCiLibName :: UnitId -> String mkGHCiLibName lib = getHSLibraryName lib <.> "o"  -- -----------------------------------------------------------------------------@@ -757,11 +728,11 @@    where     cid = compilerId (compiler lbi)-    libName = componentLibraryName clbi-    vanillaLibName = mkLibName           libName-    profileLibName = mkProfLibName       libName-    ghciLibName    = mkGHCiLibName       libName-    sharedLibName  = mkSharedLibName cid libName+    lib_name = componentUnitId clbi+    vanillaLibName = mkLibName           lib_name+    profileLibName = mkProfLibName       lib_name+    ghciLibName    = mkGHCiLibName       lib_name+    sharedLibName  = mkSharedLibName cid lib_name      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))@@ -777,14 +748,12 @@  registerPackage   :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool+  -> ProgramConfiguration   -> PackageDBStack+  -> InstalledPackageInfo   -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs+registerPackage verbosity progdb packageDbs installedPkgInfo =+  HcPkg.reregister (hcPkgInfo progdb) verbosity packageDbs     (Right installedPkgInfo)  hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo@@ -792,7 +761,10 @@                                  , HcPkg.noPkgDbStack    = False                                  , HcPkg.noVerboseFlag   = False                                  , HcPkg.flagPackageConf = False-                                 , HcPkg.useSingleFileDb = True+                                 , HcPkg.supportsDirDbs  = True+                                 , HcPkg.requiresDirDbs  = True+                                 , HcPkg.nativeMultiInstance  = False -- ?+                                 , HcPkg.recacheMultiInstance = False -- ?                                  }   where     Just lhcPkgProg = lookupProgram lhcPkgProgram conf
cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternGuards #-}  ----------------------------------------------------------------------------- -- |@@ -20,15 +21,20 @@ module Distribution.Simple.LocalBuildInfo (         LocalBuildInfo(..),         externalPackageDeps,-        inplacePackageId,-        localPackageKey,-        localLibraryName,+        localComponentId,+        localUnitId,+        localCompatPackageKey,          -- * Buildable package components         Component(..),         ComponentName(..),+        defaultLibName,         showComponentName,+        componentNameString,         ComponentLocalBuildInfo(..),+        getLocalComponent,+        componentComponentId,+        componentBuildDir,         foldComponent,         componentName,         componentBuildInfo,@@ -39,6 +45,8 @@         pkgEnabledComponents,         lookupComponent,         getComponent,+        maybeGetDefaultLibraryLocalBuildInfo,+        maybeGetComponentLocalBuildInfo,         getComponentLocalBuildInfo,         allComponentsInBuildOrder,         componentsInBuildOrder,@@ -55,6 +63,7 @@         -- * Installation directories         module Distribution.Simple.InstallDirs,         absoluteInstallDirs, prefixRelativeInstallDirs,+        absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs,         substPathTemplate   ) where @@ -63,30 +72,16 @@                                                prefixRelativeInstallDirs,                                                substPathTemplate, ) import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Simple.Program import Distribution.PackageDescription-         ( PackageDescription(..), withLib, Library(libBuildInfo), withExe-         , Executable(exeName, buildInfo), withTest, TestSuite(..)-         , BuildInfo(buildable), Benchmark(..), ModuleRenaming(..) ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageId, Package(..), InstalledPackageId(..)-         , PackageName, LibraryName(..), PackageKey(..) ) import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, PackageDBStack, DebugInfoLevel-         , OptimisationLevel, ProfDetailLevel ) import Distribution.Simple.PackageIndex-         ( InstalledPackageIndex, allPackages )-import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Setup-         ( ConfigFlags ) import Distribution.Simple.Utils-         ( shortRelativePath ) import Distribution.Text-         ( display ) import Distribution.System-         ( Platform (..) )  import Data.Array ((!)) import Distribution.Compat.Binary (Binary)@@ -95,7 +90,7 @@ import Data.Maybe import Data.Tree  (flatten) import GHC.Generics (Generic)-import Data.Map (Map)+import System.FilePath  import System.Directory (doesDirectoryExist, canonicalizePath) @@ -105,6 +100,8 @@         configFlags   :: ConfigFlags,         -- ^ Options passed to the configuration step.         -- Needed to re-run configuration when .cabal is out of date+        flagAssignment :: FlagAssignment,+        -- ^ The final set of flags which were picked for this package         extraConfigArgs     :: [String],         -- ^ Extra args on the command line for the configuration step.         -- Needed to re-run configuration when .cabal is out of date@@ -118,18 +115,21 @@                 -- ^ The platform we're building for         buildDir      :: FilePath,                 -- ^ Where to build the package.-        componentsConfigs   :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],-                -- ^ All the components to build, ordered by topological sort, and with their dependencies-                -- over the intrapackage dependency graph+        componentsConfigs   :: [(ComponentLocalBuildInfo, [UnitId])],+                -- ^ All the components to build, ordered by topological+                -- sort, and with their INTERNAL dependencies over the+                -- intrapackage dependency graph.+                -- TODO: this is assumed to be short; otherwise we want+                -- some sort of ordered map.         installedPkgs :: InstalledPackageIndex,                 -- ^ All the info about the installed packages that the                 -- current package depends on (directly or indirectly).+                -- Does NOT include internal dependencies.         pkgDescrFile  :: Maybe FilePath,                 -- ^ the filename containing the .cabal file, if available         localPkgDescr :: PackageDescription,                 -- ^ The resolved package description, that does not contain                 -- any conditionals.-        instantiatedWith :: [(ModuleName, (InstalledPackageInfo, ModuleName))],         withPrograms  :: ProgramConfiguration, -- ^Location and args for all programs         withPackageDB :: PackageDBStack,  -- ^What package database to use, global\/user         withVanillaLib:: Bool,  -- ^Whether to build normal libs.@@ -152,48 +152,53 @@  instance Binary LocalBuildInfo --- | Extract the 'PackageKey' from the library component of a--- 'LocalBuildInfo' if it exists, or make a fake package key based+-- TODO: Get rid of these functions, as much as possible.  They are+-- a bit useful in some cases, but you should be very careful!++-- | Extract the 'ComponentId' from the public library component of a+-- 'LocalBuildInfo' if it exists, or make a fake component ID based -- on the package ID.-localPackageKey :: LocalBuildInfo -> PackageKey-localPackageKey lbi =-    foldr go (OldPackageKey (package (localPkgDescr lbi))) (componentsConfigs lbi)-  where go (_, clbi, _) old_pk = case clbi of-            LibComponentLocalBuildInfo { componentPackageKey = pk } -> pk-            _ -> old_pk+localComponentId :: LocalBuildInfo -> ComponentId+localComponentId lbi+    = case localUnitId lbi of+        SimpleUnitId cid -> cid --- | Extract the 'LibraryName' from the library component of a--- 'LocalBuildInfo' if it exists, or make a library name based+-- | Extract the 'UnitId' from the library component of a+-- 'LocalBuildInfo' if it exists, or make a fake unit ID based on+-- the package ID.+localUnitId :: LocalBuildInfo -> UnitId+localUnitId lbi+    = case maybeGetDefaultLibraryLocalBuildInfo lbi of+        Just LibComponentLocalBuildInfo { componentUnitId = uid } -> uid+        -- Something fake:+        _ -> mkLegacyUnitId (package (localPkgDescr lbi))++-- | Extract the compatibility package key from the public library component of a+-- 'LocalBuildInfo' if it exists, or make a fake package key based -- on the package ID.-localLibraryName :: LocalBuildInfo -> LibraryName-localLibraryName lbi =-    foldr go (LibraryName (display (package (localPkgDescr lbi)))) (componentsConfigs lbi)-  where go (_, clbi, _) old_n = case clbi of-            LibComponentLocalBuildInfo { componentLibraryName = n } -> n-            _ -> old_n+localCompatPackageKey :: LocalBuildInfo -> String+localCompatPackageKey lbi =+    case maybeGetDefaultLibraryLocalBuildInfo lbi of+        Just LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> pk+        -- Something fake:+        _ -> display (package (localPkgDescr lbi))  -- | External package dependencies for the package as a whole. This is the -- union of the individual 'componentPackageDeps', less any internal deps.-externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]+externalPackageDeps :: LocalBuildInfo -> [(UnitId, PackageId)] externalPackageDeps lbi =     -- TODO:  what about non-buildable components?     nub [ (ipkgid, pkgid)-        | (_,clbi,_)      <- componentsConfigs lbi+        | (clbi,_)      <- componentsConfigs lbi         , (ipkgid, pkgid) <- componentPackageDeps clbi-        , not (internal pkgid) ]+        , not (internal ipkgid) ]   where     -- True if this dependency is an internal one (depends on the library     -- defined in the same package).-    internal pkgid = pkgid == packageId (localPkgDescr lbi)---- | The installed package Id we use for local packages registered in the local--- package db. This is what is used for intra-package deps between components.----inplacePackageId :: PackageId -> InstalledPackageId-inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace")+    internal ipkgid = any ((==ipkgid) . componentUnitId . fst) (componentsConfigs lbi)  -- -------------------------------------------------------------------------------- Buildable components+-- Source-representation of buildable components  data Component = CLib   Library                | CExe   Executable@@ -201,48 +206,23 @@                | CBench Benchmark                deriving (Show, Eq, Read) -data ComponentName = CLibName   -- currently only a single lib-                   | CExeName   String-                   | CTestName  String-                   | CBenchName String-                   deriving (Eq, Generic, Ord, Read, Show)--instance Binary ComponentName+-- | This gets the 'String' component name. In fact, it is+-- guaranteed to uniquely identify a component, returning+-- @Nothing@ if the 'ComponentName' was for the public+-- library (which CAN conflict with an executable name.)+componentNameString :: PackageName -> ComponentName -> Maybe String+componentNameString (PackageName pkg_name) (CLibName n) | pkg_name == n = Nothing+componentNameString _ (CLibName   n) = Just n+componentNameString _ (CExeName   n) = Just n+componentNameString _ (CTestName  n) = Just n+componentNameString _ (CBenchName n) = Just n  showComponentName :: ComponentName -> String-showComponentName CLibName          = "library"+showComponentName (CLibName   name) = "library '" ++ name ++ "'" showComponentName (CExeName   name) = "executable '" ++ name ++ "'" showComponentName (CTestName  name) = "test suite '" ++ name ++ "'" showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" -data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    -- | Resolved internal and external package dependencies for this component.-    -- The 'BuildInfo' specifies a set of build dependencies that must be-    -- satisfied in terms of version ranges. This field fixes those dependencies-    -- to the specific versions available on this machine for this compiler.-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageKey :: PackageKey,-    componentLibraryName :: LibraryName,-    componentExposedModules :: [Installed.ExposedModule],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  | ExeComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  | TestComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  | BenchComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  deriving (Generic, Read, Show)--instance Binary ComponentLocalBuildInfo- foldComponent :: (Library -> a)               -> (Executable -> a)               -> (TestSuite -> a)@@ -260,7 +240,7 @@  componentName :: Component -> ComponentName componentName =-  foldComponent (const CLibName)+  foldComponent (CLibName . libName)                 (CExeName . exeName)                 (CTestName . testName)                 (CBenchName . benchmarkName)@@ -269,7 +249,7 @@ -- pkgComponents :: PackageDescription -> [Component] pkgComponents pkg =-    [ CLib  lib | Just lib <- [library pkg] ]+    [ CLib  lib | lib <- libraries pkg ]  ++ [ CExe  exe | exe <- executables pkg ]  ++ [ CTest tst | tst <- testSuites  pkg ]  ++ [ CBench bm | bm  <- benchmarks  pkg ]@@ -302,8 +282,9 @@ componentDisabledReason _                   = Nothing  lookupComponent :: PackageDescription -> ComponentName -> Maybe Component-lookupComponent pkg CLibName =-    fmap CLib $ library pkg+lookupComponent pkg (CLibName "") = lookupComponent pkg (defaultLibName (package pkg))+lookupComponent pkg (CLibName name) =+    fmap CLib $ find ((name ==) . libName) (libraries pkg) lookupComponent pkg (CExeName name) =     fmap CExe $ find ((name ==) . exeName) (executables pkg) lookupComponent pkg (CTestName name) =@@ -321,43 +302,149 @@       error $ "internal error: the package description contains no "            ++ "component corresponding to " ++ show cname +-- -----------------------------------------------------------------------------+-- Configuration information of buildable components +data ComponentLocalBuildInfo+  = LibComponentLocalBuildInfo {+    -- | It would be very convenient to store the literal Library here,+    -- but if we do that, it will get serialized (via the Binary)+    -- instance twice.  So instead we just provide the ComponentName,+    -- which can be used to find the Component in the+    -- PackageDescription.  NB: eventually, this will NOT uniquely+    -- identify the ComponentLocalBuildInfo.+    componentLocalName :: ComponentName,+    -- | Resolved internal and external package dependencies for this component.+    -- The 'BuildInfo' specifies a set of build dependencies that must be+    -- satisfied in terms of version ranges. This field fixes those dependencies+    -- to the specific versions available on this machine for this compiler.+    componentPackageDeps :: [(UnitId, PackageId)],+    -- | The computed 'UnitId' which uniquely identifies this+    -- component.+    componentUnitId :: UnitId,+    -- | Compatibility "package key" that we pass to older versions of GHC.+    componentCompatPackageKey :: String,+    -- | Compatability "package name" that we register this component as.+    componentCompatPackageName :: PackageName,+    -- | A list of exposed modules (either defined in this component,+    -- or reexported from another component.)+    componentExposedModules :: [Installed.ExposedModule],+    -- | Convenience field, specifying whether or not this is the+    -- "public library" that has the same name as the package.+    componentIsPublic :: Bool,+    -- | The set of packages that are brought into scope during+    -- compilation, including a 'ModuleRenaming' which may used+    -- to hide or rename modules.  This is what gets translated into+    -- @-package-id@ arguments.  This is a modernized version of+    -- 'componentPackageDeps', which is kept around for BC purposes.+    componentIncludes :: [(UnitId, ModuleRenaming)]+  }+  | ExeComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(UnitId, ModuleRenaming)]+  }+  | TestComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(UnitId, ModuleRenaming)]+  }+  | BenchComponentLocalBuildInfo {+    componentLocalName :: ComponentName,+    componentUnitId :: UnitId,+    componentPackageDeps :: [(UnitId, PackageId)],+    componentIncludes :: [(UnitId, ModuleRenaming)]+  }+  deriving (Generic, Read, Show)++instance Binary ComponentLocalBuildInfo++getLocalComponent :: PackageDescription -> ComponentLocalBuildInfo -> Component+getLocalComponent pkg_descr clbi = getComponent pkg_descr (componentLocalName clbi)++componentComponentId :: ComponentLocalBuildInfo -> ComponentId+componentComponentId clbi = case componentUnitId clbi of+                                SimpleUnitId cid -> cid++componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath+componentBuildDir lbi LibComponentLocalBuildInfo{ componentIsPublic = True }+    = buildDir lbi+-- For now, we assume that libraries/executables/test-suites/benchmarks+-- are only ever built once.  With Backpack, we need a special case for+-- libraries so that we can handle building them multiple times.+componentBuildDir lbi clbi+    = buildDir lbi </> case componentLocalName clbi of+                        CLibName s   -> s+                        CExeName s   -> s+                        CTestName s  -> s+                        CBenchName s -> s+ getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname =+    case maybeGetComponentLocalBuildInfo lbi cname of+      Just clbi -> clbi+      Nothing   ->+          error $ "internal error: there is no configuration data "+               ++ "for component " ++ show cname++maybeGetComponentLocalBuildInfo+    :: LocalBuildInfo -> ComponentName -> Maybe ComponentLocalBuildInfo+maybeGetComponentLocalBuildInfo lbi cname =     case [ clbi-         | (cname', clbi, _) <- componentsConfigs lbi-         , cname == cname' ] of-      [clbi] -> clbi-      _      -> missingComponent-  where-    missingComponent =-      error $ "internal error: there is no configuration data "-           ++ "for component " ++ show cname+         | (clbi, _) <- componentsConfigs lbi+         , cid <- componentNameToUnitIds lbi cname+         , cid == componentUnitId clbi ] of+      [clbi] -> Just clbi+      _      -> Nothing +maybeGetDefaultLibraryLocalBuildInfo+    :: LocalBuildInfo+    -> Maybe ComponentLocalBuildInfo+maybeGetDefaultLibraryLocalBuildInfo lbi =+    case [ clbi+         | (clbi@LibComponentLocalBuildInfo{}, _) <- componentsConfigs lbi+         , componentIsPublic clbi+         ] of+      [clbi] -> Just clbi+      _ -> Nothing --- |If the package description has a library section, call the given---  function with the library build info as argument.  Extended version of--- 'withLib' that also gives corresponding build info.+componentNameToUnitIds :: LocalBuildInfo -> ComponentName -> [UnitId]+componentNameToUnitIds lbi cname =+    [ componentUnitId clbi+    | (clbi, _) <- componentsConfigs lbi+    , componentName (getLocalComponent (localPkgDescr lbi) clbi) == cname ]++-- | Perform the action on each buildable 'library' in the package+-- description.  Extended version of 'withLib' that also gives+-- corresponding build info. withLibLBI :: PackageDescription -> LocalBuildInfo            -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withLibLBI pkg_descr lbi f =-    withLib pkg_descr $ \lib ->-      f lib (getComponentLocalBuildInfo lbi CLibName)+withLibLBI pkg lbi f =+    sequence_+        [ f lib clbi+        | (clbi@LibComponentLocalBuildInfo{}, _) <- componentsConfigs lbi+        , CLib lib <- [getComponent pkg (componentLocalName clbi)] ]  -- | Perform the action on each buildable 'Executable' in the package -- description.  Extended version of 'withExe' that also gives corresponding -- build info. withExeLBI :: PackageDescription -> LocalBuildInfo            -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withExeLBI pkg_descr lbi f =-    withExe pkg_descr $ \exe ->-      f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe)))+withExeLBI pkg lbi f =+    sequence_+        [ f exe clbi+        | (clbi@ExeComponentLocalBuildInfo{}, _) <- componentsConfigs lbi+        , CExe exe <- [getComponent pkg (componentLocalName clbi)] ]  withTestLBI :: PackageDescription -> LocalBuildInfo             -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withTestLBI pkg_descr lbi f =-    withTest pkg_descr $ \test ->-      f test (getComponentLocalBuildInfo lbi (CTestName (testName test)))+withTestLBI pkg lbi f =+    sequence_+        [ f test clbi+        | (clbi@TestComponentLocalBuildInfo{}, _) <- componentsConfigs lbi+        , CTest test <- [getComponent pkg (componentLocalName clbi)] ]  {-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} withComponentsLBI :: PackageDescription -> LocalBuildInfo@@ -373,37 +460,44 @@                               -> IO () withAllComponentsInBuildOrder pkg lbi f =     sequence_-      [ f (getComponent pkg cname) clbi-      | (cname, clbi) <- allComponentsInBuildOrder lbi ]+      [ f (getLocalComponent pkg clbi) clbi+      | clbi <- allComponentsInBuildOrder lbi ]  withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo-                                  -> [ComponentName]-                                  -> (Component -> ComponentLocalBuildInfo -> IO ())-                                  -> IO ()+                           -> [ComponentName]+                           -> (Component -> ComponentLocalBuildInfo -> IO ())+                           -> IO () withComponentsInBuildOrder pkg lbi cnames f =     sequence_-      [ f (getComponent pkg cname') clbi-      | (cname', clbi) <- componentsInBuildOrder lbi cnames ]+      [ f (getLocalComponent pkg clbi) clbi+      | clbi <- componentsInBuildOrder lbi cnames ]  allComponentsInBuildOrder :: LocalBuildInfo-                          -> [(ComponentName, ComponentLocalBuildInfo)]+                          -> [ComponentLocalBuildInfo] allComponentsInBuildOrder lbi =-    componentsInBuildOrder lbi-      [ cname | (cname, _, _) <- componentsConfigs lbi ]+    componentsInBuildOrder' lbi+      [ componentUnitId clbi | (clbi, _) <- componentsConfigs lbi ]  componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]-                       -> [(ComponentName, ComponentLocalBuildInfo)]+                       -> [ComponentLocalBuildInfo] componentsInBuildOrder lbi cnames =-      map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode)+    componentsInBuildOrder' lbi+        (concatMap (componentNameToUnitIds lbi) cnames)++componentsInBuildOrder' :: LocalBuildInfo -> [UnitId]+                       -> [ComponentLocalBuildInfo]+componentsInBuildOrder' lbi cids =+      map ((\(clbi,_,_) -> clbi) . vertexToNode)     . postOrder graph-    . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname))-    $ cnames+    . map (\cid -> fromMaybe (noSuchComp cid) (keyToVertex cid))+    $ cids   where     (graph, vertexToNode, keyToVertex) =-      graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi))+      graphFromEdges (map (\(clbi,internal_deps) ->+                            (clbi,componentUnitId clbi,internal_deps)) (componentsConfigs lbi)) -    noSuchComp cname = error $ "internal error: componentsInBuildOrder: "-                            ++ "no such component: " ++ show cname+    noSuchComp cid = error $ "internal error: componentsInBuildOrder: "+                            ++ "no such component: " ++ show cid      postOrder :: Graph -> [Vertex] -> [Vertex]     postOrder g vs = postorderF (dfs g vs) []@@ -437,27 +531,30 @@                 -> IO [FilePath] depLibraryPaths inplace relative lbi clbi = do     let pkgDescr    = localPkgDescr lbi-        installDirs = absoluteInstallDirs pkgDescr lbi NoCopyDest+        installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest         executable  = case clbi of                         ExeComponentLocalBuildInfo {} -> True                         _                             -> False         relDir | executable = bindir installDirs                | otherwise  = libdir installDirs -    let hasInternalDeps = not $ null-                        $ [ pkgid-                          | (_,pkgid) <- componentPackageDeps clbi-                          , internal pkgid-                          ]+    let -- TODO: this is kind of inefficient+        internalDeps = [ cid+                       | (cid, _) <- componentPackageDeps clbi+                       -- Test that it's internal+                       , (sub_clbi, _) <- componentsConfigs lbi+                       , componentUnitId sub_clbi == cid ]+        internalLibs = [ getLibDir sub_clbi+                       | sub_clbi <- componentsInBuildOrder'+                                        lbi internalDeps ]+        getLibDir sub_clbi+          | inplace    = componentBuildDir lbi sub_clbi+          | otherwise  = libdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)      let ipkgs          = allPackages (installedPkgs lbi)         allDepLibDirs  = concatMap Installed.libraryDirs ipkgs-        internalLib-          | inplace    = buildDir lbi-          | otherwise  = libdir installDirs-        allDepLibDirs' = if hasInternalDeps-                            then internalLib : allDepLibDirs-                            else allDepLibDirs++        allDepLibDirs' = internalLibs ++ allDepLibDirs     allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs'      let p                = prefix installDirs@@ -473,7 +570,6 @@      return libPaths   where-    internal pkgid = pkgid == packageId (localPkgDescr lbi)     -- 'canonicalizePath' fails on UNIX when the directory does not exists.     -- So just don't canonicalize when it doesn't exist.     canonicalizePathNoFail p = do@@ -486,35 +582,58 @@ -- ----------------------------------------------------------------------------- -- Wrappers for a couple functions from InstallDirs --- |See 'InstallDirs.absoluteInstallDirs'-absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest+-- | Backwards compatibility function which computes the InstallDirs+-- assuming that @$libname@ points to the public library (or some fake+-- package identifier if there is no public library.)  IF AT ALL+-- POSSIBLE, please use 'absoluteComponentInstallDirs' instead.+absoluteInstallDirs :: PackageDescription -> LocalBuildInfo+                    -> CopyDest                     -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest =+    absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest++-- | See 'InstallDirs.absoluteInstallDirs'.+absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo+                             -> UnitId+                             -> CopyDest+                             -> InstallDirs FilePath+absoluteComponentInstallDirs pkg lbi uid copydest =   InstallDirs.absoluteInstallDirs     (packageId pkg)-    (localLibraryName lbi)+    uid     (compilerInfo (compiler lbi))     copydest     (hostPlatform lbi)     (installDirTemplates lbi) --- |See 'InstallDirs.prefixRelativeInstallDirs'+-- | Backwards compatibility function which computes the InstallDirs+-- assuming that @$libname@ points to the public library (or some fake+-- package identifier if there is no public library.)  IF AT ALL+-- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo                           -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi =+    prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi)++-- |See 'InstallDirs.prefixRelativeInstallDirs'+prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo+                                   -> UnitId+                                   -> InstallDirs (Maybe FilePath)+prefixRelativeComponentInstallDirs pkg_descr lbi uid =   InstallDirs.prefixRelativeInstallDirs     (packageId pkg_descr)-    (localLibraryName lbi)+    uid     (compilerInfo (compiler lbi))     (hostPlatform lbi)     (installDirTemplates lbi)  substPathTemplate :: PackageId -> LocalBuildInfo+                  -> UnitId                   -> PathTemplate -> FilePath-substPathTemplate pkgid lbi = fromPathTemplate-                                . ( InstallDirs.substPathTemplate env )+substPathTemplate pkgid lbi uid = fromPathTemplate+                                    . ( InstallDirs.substPathTemplate env )     where env = initialPathTemplateEnv                    pkgid-                   (localLibraryName lbi)+                   uid                    (compilerInfo (compiler lbi))                    (hostPlatform lbi)
cabal/Cabal/Distribution/Simple/PackageIndex.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}  -----------------------------------------------------------------------------@@ -11,8 +10,51 @@ -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- An index of packages.+-- An index of packages whose primary key is 'UnitId'.  Public libraries+-- are additionally indexed by 'PackageName' and 'Version'.+-- Technically, these are an index of *units* (so we should eventually+-- rename it to 'UnitIndex'); but in the absence of internal libraries+-- or Backpack each unit is equivalent to a package. --+-- 'PackageIndex' is parametric over what it actually records, and it+-- is used in two ways:+--+--      * The 'InstalledPackageIndex' (defined here) contains a graph of+--        'InstalledPackageInfo's representing the packages in a+--        package database stack.  It is used in a variety of ways:+--+--          * The primary use to let Cabal access the same installed+--            package database which is used by GHC during compilation.+--            For example, this data structure is used by 'ghc-pkg'+--            and 'Cabal' to do consistency checks on the database+--            (are the references closed).+--+--          * Given a set of dependencies, we can compute the transitive+--            closure of dependencies.  This is to check if the versions+--            of packages are consistent, and also needed by multiple+--            tools (Haddock must be explicitly told about the every+--            transitive package to do cross-package linking;+--            preprocessors must know about the include paths of all+--            transitive dependencies.)+--+--      * The 'PlanIndex' (defined in 'Distribution.Client.InstallPlan'),+--        contains a graph of 'GenericPlanPackage'.  Ignoring its type+--        parameters for a moment, a 'PlanIndex' is an extension of the+--        'InstalledPackageIndex' to also record nodes for packages+--        which are *planned* to be installed, but not actually+--        installed yet.  A 'PlanIndex' containing only 'PreExisting'+--        packages is essentially a 'PackageIndex'.+--+--        'PlanIndex'es actually require some auxiliary information, so+--        most users interact with a 'GenericInstallPlan'.  This type is+--        specialized as an 'ElaboratedInstallPlan' (for @cabal+--        new-build@) or an 'InstallPlan' (for @cabal install@).+--+-- This 'PackageIndex' is NOT to be confused with+-- 'Distribution.Client.PackageIndex', which indexes packages only by+-- 'PackageName' (this makes it suitable for indexing source packages,+-- for which we don't know 'UnitId's.)+-- module Distribution.Simple.PackageIndex (   -- * Package index data type   InstalledPackageIndex,@@ -26,7 +68,7 @@    insert, -  deleteInstalledPackageId,+  deleteUnitId,   deleteSourcePackageId,   deletePackageName, --  deleteDependency,@@ -34,7 +76,7 @@   -- * Queries    -- ** Precise lookups-  lookupInstalledPackageId,+  lookupUnitId,   lookupSourcePackageId,   lookupPackageId,   lookupPackageName,@@ -60,19 +102,27 @@   dependencyCycles,   dependencyGraph,   moduleNameIndex,++  -- * Backwards compatibility+  deleteInstalledPackageId,+  lookupInstalledPackageId,   ) where +import Distribution.Compat.Binary+import Distribution.Compat.Semigroup as Semi+import Distribution.Package+import Distribution.ModuleName+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Version+import Distribution.Simple.Utils+ import Control.Exception (assert) import Data.Array ((!)) import qualified Data.Array as Array-import Distribution.Compat.Binary (Binary) import qualified Data.Graph as Graph import Data.List as List          ( null, foldl', sort-         , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif+         , groupBy, sortBy, find, nubBy, deleteBy, deleteFirstsBy ) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isNothing, fromMaybe)@@ -80,32 +130,17 @@ import GHC.Generics (Generic) import Prelude hiding (lookup) -import Distribution.Package-         ( PackageName(..), PackageId-         , Package(..), packageName, packageVersion-         , Dependency(Dependency)--, --PackageFixedDeps(..)-         , InstalledPackageId(..)-         , HasInstalledPackageId(..), PackageInstalled(..) )-import Distribution.ModuleName-         ( ModuleName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, comparing, equating)- -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled' ----- Packages are uniquely identified in by their 'InstalledPackageId', they can+-- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. -- data PackageIndex a = PackageIndex   -- The primary index. Each InstalledPackageInfo record is uniquely identified-  -- by its InstalledPackageId.+  -- by its UnitId.   ---  !(Map InstalledPackageId a)+  !(Map UnitId a)    -- This auxiliary index maps package names (case-sensitively) to all the   -- versions and instances of that package. This allows us to find all@@ -113,39 +148,42 @@   --   -- It is a three-level index. The first level is the package name,   -- the second is the package version and the final level is instances-  -- of the same package version. These are unique by InstalledPackageId+  -- of the same package version. These are unique by UnitId   -- and are kept in preference order.   --   -- FIXME: Clarify what "preference order" means. Check that this invariant is   -- preserved. See #1463 for discussion.   !(Map PackageName (Map Version [a])) -  deriving (Generic, Show, Read)+  deriving (Eq, Generic, Show, Read)  instance Binary a => Binary (PackageIndex a)  -- | The default package index which contains 'InstalledPackageInfo'.  Normally -- use this.-type InstalledPackageIndex = PackageIndex InstalledPackageInfo+type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo -instance HasInstalledPackageId a => Monoid (PackageIndex a) where+instance HasUnitId a => Monoid (PackageIndex a) where   mempty  = PackageIndex Map.empty Map.empty-  mappend = merge+  mappend = (Semi.<>)   --save one mappend with empty in the common case:   mconcat [] = mempty   mconcat xs = foldr1 mappend xs -invariant :: HasInstalledPackageId a => PackageIndex a -> Bool+instance HasUnitId a => Semigroup (PackageIndex a) where+  (<>) = merge++invariant :: HasUnitId a => PackageIndex a -> Bool invariant (PackageIndex pids pnames) =-     map installedPackageId (Map.elems pids)+     map installedUnitId (Map.elems pids)   == sort-     [ assert pinstOk (installedPackageId pinst)+     [ assert pinstOk (installedUnitId pinst)      | (pname, pvers)  <- Map.toList pnames      , let pversOk = not (Map.null pvers)      , (pver,  pinsts) <- assert pversOk $ Map.toList pvers-     , let pinsts'  = sortBy (comparing installedPackageId) pinsts+     , let pinsts'  = sortBy (comparing installedUnitId) pinsts            pinstsOk = all (\g -> length g == 1)-                          (groupBy (equating installedPackageId) pinsts')+                          (groupBy (equating installedUnitId) pinsts')      , pinst           <- assert pinstsOk $ pinsts'      , let pinstOk = packageName    pinst == pname                   && packageVersion pinst == pver@@ -156,8 +194,8 @@ -- * Internal helpers -- -mkPackageIndex :: HasInstalledPackageId a-               => Map InstalledPackageId a+mkPackageIndex :: HasUnitId a+               => Map UnitId a                -> Map PackageName (Map Version [a])                -> PackageIndex a mkPackageIndex pids pnames = assert (invariant index) index@@ -170,13 +208,13 @@  -- | Build an index out of a bunch of packages. ----- If there are duplicates by 'InstalledPackageId' then later ones mask earlier+-- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. ---fromList :: HasInstalledPackageId a => [a] -> PackageIndex a+fromList :: HasUnitId a => [a] -> PackageIndex a fromList pkgs = mkPackageIndex pids pnames   where-    pids      = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ]+    pids      = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]     pnames    =       Map.fromList         [ (packageName (head pkgsN), pvers)@@ -186,7 +224,7 @@         , let pvers =                 Map.fromList                 [ (packageVersion (head pkgsNV),-                   nubBy (equating installedPackageId) (reverse pkgsNV))+                   nubBy (equating installedUnitId) (reverse pkgsNV))                 | pkgsNV <- groupBy (equating packageVersion) pkgsN                 ]         ]@@ -198,14 +236,14 @@ -- | Merge two indexes. -- -- Packages from the second mask packages from the first if they have the exact--- same 'InstalledPackageId'.+-- same 'UnitId'. -- -- For packages with the same source 'PackageId', packages from the second are -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. ---merge :: HasInstalledPackageId a => PackageIndex a -> PackageIndex a+merge :: HasUnitId a => PackageIndex a -> PackageIndex a       -> PackageIndex a merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =   mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)@@ -214,7 +252,7 @@     -- Packages in the second list mask those in the first, however preferred     -- packages go first in the list.     mergeBuckets xs ys = ys ++ (xs \\ ys)-    (\\) = deleteFirstsBy (equating installedPackageId)+    (\\) = deleteFirstsBy (equating installedUnitId)   -- | Inserts a single package into the index.@@ -222,12 +260,12 @@ -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. ---insert :: HasInstalledPackageId a => a -> PackageIndex a -> PackageIndex a+insert :: HasUnitId a => a -> PackageIndex a -> PackageIndex a insert pkg (PackageIndex pids pnames) =     mkPackageIndex pids' pnames'    where-    pids'   = Map.insert (installedPackageId pkg) pkg pids+    pids'   = Map.insert (installedUnitId pkg) pkg pids     pnames' = insertPackageName pnames     insertPackageName =       Map.insertWith' (\_ -> insertPackageVersion)@@ -239,15 +277,15 @@                      (packageVersion pkg) [pkg]      insertPackageInstance pkgs =-      pkg : deleteBy (equating installedPackageId) pkg pkgs+      pkg : deleteBy (equating installedUnitId) pkg pkgs   -- | Removes a single installed package from the index. ---deleteInstalledPackageId :: HasInstalledPackageId a-                         => InstalledPackageId -> PackageIndex a-                         -> PackageIndex a-deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) =+deleteUnitId :: HasUnitId a+             => UnitId -> PackageIndex a+             -> PackageIndex a+deleteUnitId ipkgid original@(PackageIndex pids pnames) =   case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of     (Nothing,     _)     -> original     (Just spkgid, pids') -> mkPackageIndex pids'@@ -263,12 +301,18 @@      deletePkgInstance =         (\xs -> if List.null xs then Nothing else Just xs)-      . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined+      . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined +-- | Backwards compatibility wrapper for Cabal pre-1.24.+{-# DEPRECATED deleteInstalledPackageId "Use deleteUnitId instead" #-}+deleteInstalledPackageId :: HasUnitId a+                         => UnitId -> PackageIndex a+                         -> PackageIndex a+deleteInstalledPackageId = deleteUnitId  -- | Removes all packages with this source 'PackageId' from the index. ---deleteSourcePackageId :: HasInstalledPackageId a => PackageId -> PackageIndex a+deleteSourcePackageId :: HasUnitId a => PackageId -> PackageIndex a                       -> PackageIndex a deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =   case Map.lookup (packageName pkgid) pnames of@@ -276,7 +320,7 @@     Just pvers  -> case Map.lookup (packageVersion pkgid) pvers of       Nothing   -> original       Just pkgs -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedPackageId)) pids pkgs)+                     (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)                      (deletePkgName pnames)   where     deletePkgName =@@ -289,13 +333,13 @@  -- | Removes all packages with this (case-sensitive) name from the index. ---deletePackageName :: HasInstalledPackageId a => PackageName -> PackageIndex a+deletePackageName :: HasUnitId a => PackageName -> PackageIndex a                   -> PackageIndex a deletePackageName name original@(PackageIndex pids pnames) =   case Map.lookup name pnames of     Nothing     -> original     Just pvers  -> mkPackageIndex-                     (foldl' (flip (Map.delete . installedPackageId)) pids+                     (foldl' (flip (Map.delete . installedUnitId)) pids                              (concat (Map.elems pvers)))                      (Map.delete name pnames) @@ -329,7 +373,7 @@ -- -- They are grouped by source package id (package name and version). ---allPackagesBySourcePackageId :: HasInstalledPackageId a => PackageIndex a+allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a                              -> [(PackageId, [a])] allPackagesBySourcePackageId (PackageIndex _ pnames) =   [ (packageId ipkg, ipkgs)@@ -342,18 +386,24 @@  -- | Does a lookup by source package id (name & version). ----- Since multiple package DBs mask each other by 'InstalledPackageId',+-- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. ---lookupInstalledPackageId :: PackageIndex a -> InstalledPackageId+lookupUnitId :: PackageIndex a -> UnitId+             -> Maybe a+lookupUnitId (PackageIndex pids _) pid = Map.lookup pid pids++-- | Backwards compatibility for Cabal pre-1.24.+{-# DEPRECATED lookupInstalledPackageId "Use lookupUnitId instead" #-}+lookupInstalledPackageId :: PackageIndex a -> UnitId                          -> Maybe a-lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids+lookupInstalledPackageId = lookupUnitId   -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId'--- but different 'InstalledPackageId'. They are returned in order of+-- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first. -- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]@@ -457,7 +507,7 @@ dependencyCycles index =   [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]   where-    adjacencyList = [ (pkg, installedPackageId pkg, installedDepends pkg)+    adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg)                     | pkg <- allPackages index ]  @@ -466,12 +516,12 @@ -- Returns such packages along with the dependencies that they're missing. -- brokenPackages :: PackageInstalled a => PackageIndex a-               -> [(a, [InstalledPackageId])]+               -> [(a, [UnitId])] brokenPackages index =   [ (pkg, missing)   | pkg  <- allPackages index   , let missing = [ pkg' | pkg' <- installedDepends pkg-                         , isNothing (lookupInstalledPackageId index pkg') ]+                         , isNothing (lookupUnitId index pkg') ]   , not (null missing) ]  -- | Tries to take the transitive closure of the package dependencies.@@ -483,17 +533,17 @@ -- the original given 'PackageId's do not occur in the index. -- dependencyClosure :: PackageInstalled a => PackageIndex a-                  -> [InstalledPackageId]+                  -> [UnitId]                   -> Either (PackageIndex a)-                            [(a, [InstalledPackageId])]+                            [(a, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of   (completed, []) -> Left completed   (completed, _)  -> Right (brokenPackages completed)  where     closure completed failed []             = (completed, failed)-    closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of+    closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of       Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupInstalledPackageId completed (installedPackageId pkg) of+      Just pkg  -> case lookupUnitId completed (installedUnitId pkg) of         Just _  -> closure completed  failed pkgids         Nothing -> closure completed' failed pkgids'           where completed' = insert pkg completed@@ -504,7 +554,7 @@ -- * The given 'PackageId's must be in the index. -- reverseDependencyClosure :: PackageInstalled a => PackageIndex a-                         -> [InstalledPackageId]+                         -> [UnitId]                          -> [a] reverseDependencyClosure index =     map vertexToPkg@@ -538,7 +588,7 @@ dependencyGraph :: PackageInstalled a => PackageIndex a                 -> (Graph.Graph,                     Graph.Vertex -> a,-                    InstalledPackageId -> Maybe Graph.Vertex)+                    UnitId -> Maybe Graph.Vertex) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)   where     graph = Array.listArray bounds@@ -546,7 +596,7 @@               | pkg <- pkgs ]      pkgs             = sortBy (comparing packageId) (allPackages index)-    vertices         = zip (map installedPackageId pkgs) [0..]+    vertices         = zip (map installedUnitId pkgs) [0..]     vertex_map       = Map.fromList vertices     id_to_vertex pid = Map.lookup pid vertex_map @@ -583,15 +633,20 @@              Map.fromList [(ipid,(dep,[packageId pkg]))])           | pkg <- allPackages index           , ipid <- installedDepends pkg-          , Just dep <- [lookupInstalledPackageId index ipid]+          , Just dep <- [lookupUnitId index ipid]           ] +        -- Added in 991e52a474e2b8280432257c1771dc474a320a30,+        -- this is a special case to handle the base 3 compatibility+        -- package which shipped with GHC 6.10 and GHC 6.12+        -- (it was removed in GHC 7.0).  Remove this when GHC 6.12+        -- goes out of our support window.         reallyIsInconsistent :: PackageInstalled a => [a] -> Bool         reallyIsInconsistent []       = False         reallyIsInconsistent [_p]     = False         reallyIsInconsistent [p1, p2] =-          let pid1 = installedPackageId p1-              pid2 = installedPackageId p2+          let pid1 = installedUnitId p1+              pid2 = installedUnitId p2           in pid1 `notElem` installedDepends p2           && pid2 `notElem` installedDepends p1         reallyIsInconsistent _ = True@@ -600,15 +655,15 @@ -- 'InstalledPackageIndex' and turns it into a map from module names to their -- source packages.  It's used to initialize the @build-deps@ field in @cabal -- init@.-moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [InstalledPackageInfo]+moduleNameIndex :: InstalledPackageIndex -> Map ModuleName [IPI.InstalledPackageInfo] moduleNameIndex index =   Map.fromListWith (++) $ do     pkg <- allPackages index-    IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg+    IPI.ExposedModule m reexport <- IPI.exposedModules pkg     case reexport of         Nothing -> return (m, [pkg])-        Just (IPI.OriginalModule _ m') | m == m'   -> []-                                       | otherwise -> return (m', [pkg])+        Just (Module _ m') | m == m'   -> []+                           | otherwise -> return (m', [pkg])         -- The heuristic is this: we want to prefer the original package         -- which originally exported a module.  However, if a reexport         -- also *renamed* the module (m /= m'), then we have to use the
cabal/Cabal/Distribution/Simple/PreProcess.hs view
@@ -27,49 +27,25 @@     where  -import Control.Monad-import Distribution.Simple.PreProcess.Unlit (unlit)+import Distribution.Simple.PreProcess.Unlit import Distribution.Package-         ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..)-         , Executable(..)-         , Library(..), libModules-         , TestSuite(..), testModules-         , TestSuiteInterface(..)-         , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed-         ( InstalledPackageInfo(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.CCompiler-         ( cSourceExtensions ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..)-         , compilerFlavor, compilerCompatVersion, compilerVersion ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), Component(..) )-import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)+import Distribution.Simple.BuildPaths import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile-         , findFileWithExtension, findFileWithExtension'-         , getDirectoryContentsRecursive ) import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), programPath-         , requireProgram, requireProgramVersion-         , rawSystemProgramConf, rawSystemProgram-         , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram-         , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram ) import Distribution.Simple.Test.LibV09-         ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System-         ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion ) import Distribution.Verbosity +import Control.Monad import Data.Maybe (fromMaybe) import Data.List (nub, isSuffixOf) import System.Directory (doesFileExist)@@ -156,26 +132,27 @@ -- |A preprocessor for turning non-Haskell files with the given extension -- into plain Haskell source files. type PPSuffixHandler-    = (String, BuildInfo -> LocalBuildInfo -> PreProcessor)+    = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor)  -- | Apply preprocessors to the sources from 'hsSourceDirs' for a given -- component (lib, exe, or test suite). preprocessComponent :: PackageDescription                     -> Component                     -> LocalBuildInfo+                    -> ComponentLocalBuildInfo                     -> Bool                     -> Verbosity                     -> [PPSuffixHandler]                     -> IO ()-preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of+preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of   (CLib lib@Library{ libBuildInfo = bi }) -> do-    let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi]+    let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi clbi]     setupMessage verbosity "Preprocessing library" (packageId pd)     forM_ (map ModuleName.toFilePath $ libModules lib) $       pre dirs (buildDir lbi) (localHandlers bi)   (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do     let exeDir = buildDir lbi </> nm </> nm ++ "-tmp"-        dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi]+        dirs   = hsSourceDirs bi ++ [autogenModulesDir lbi clbi]     setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd)     forM_ (map ModuleName.toFilePath $ otherModules bi) $       pre dirs exeDir (localHandlers bi)@@ -206,7 +183,7 @@     builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]     builtinCSuffixes       = cSourceExtensions     builtinSuffixes        = builtinHaskellSuffixes ++ builtinCSuffixes-    localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]+    localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers]     pre dirs dir lhndlrs fp =       preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs     preProcessTest test = preProcessComponent (testBuildInfo test)@@ -215,7 +192,7 @@                          (benchmarkModules bm)     preProcessComponent bi modules exePath dir = do         let biHandlers = localHandlers bi-            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]+            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi clbi ]         sequence_ [ preprocessFile sourceDirs dir isSrcDist                 (ModuleName.toFilePath modu) verbosity builtinSuffixes                 biHandlers@@ -318,8 +295,8 @@ -- * known preprocessors -- ------------------------------------------------------------ -ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppGreenCard _ lbi+ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppGreenCard _ lbi _     = PreProcessor {         platformIndependent = False,         runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->@@ -338,21 +315,21 @@         either (writeUTF8File outFile) die (unlit inFile contents)   } -ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor+ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpp = ppCpp' [] -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppCpp' extraArgs bi lbi =+ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppCpp' extraArgs bi lbi clbi =   case compilerFlavor (compiler lbi) of-    GHC   -> ppGhcCpp ghcProgram   (>= Version [6,6] []) args bi lbi-    GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi-    _     -> ppCpphs  args bi lbi+    GHC   -> ppGhcCpp ghcProgram   (>= Version [6,6] []) args bi lbi clbi+    GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi clbi+    _     -> ppCpphs  args bi lbi clbi   where cppArgs = getCppOptions bi lbi         args    = cppArgs ++ extraArgs  ppGhcCpp :: Program -> (Version -> Bool)-         -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppGhcCpp program xHs extraArgs _bi lbi =+         -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppGhcCpp program xHs extraArgs _bi lbi clbi =   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do@@ -366,13 +343,13 @@           -- double-unlitted. In the future we might switch to           -- using cpphs --unlit instead.        ++ (if xHs version then ["-x", "hs"] else [])-       ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi </> cppHeaderName) ]+       ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi clbi </> cppHeaderName) ]        ++ ["-o", outFile, inFile]        ++ extraArgs   } -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppCpphs extraArgs _bi lbi =+ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppCpphs extraArgs _bi lbi clbi =   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do@@ -382,13 +359,13 @@           ("-O" ++ outFile) : inFile         : "--noline" : "--strip"         : (if cpphsVersion >= Version [1,6] []-             then ["--include="++ (autogenModulesDir lbi </> cppHeaderName)]+             then ["--include="++ (autogenModulesDir lbi clbi </> cppHeaderName)]              else [])         ++ extraArgs   } -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppHsc2hs bi lbi =+ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppHsc2hs bi lbi clbi =   PreProcessor {     platformIndependent = False,     runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do@@ -425,8 +402,8 @@        ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi                                       ++ PD.cppOptions   bi ]        ++ [ "--cflag="   ++ opt | opt <--               [ "-I" ++ autogenModulesDir lbi,-                 "-include", autogenModulesDir lbi </> cppHeaderName ] ]+               [ "-I" ++ autogenModulesDir lbi clbi,+                 "-include", autogenModulesDir lbi clbi </> cppHeaderName ] ]        ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]        ++ [ "--lflag=-Wl,-R," ++ opt | isELF                                 , opt <- PD.extraLibDirs bi ]@@ -448,9 +425,15 @@        ++ ["-o", outFile, inFile]   }   where+    -- TODO: installedPkgs contains ALL dependencies associated with+    -- the package, but we really only want to look at packages for the+    -- *current* dependency.  We should use PackageIndex.dependencyClosure+    -- on the direct depends of the component.  The signature of this+    -- function was recently refactored, so this should be fixable+    -- now.  Tracked with #2971 (which has a test case.)     pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))     isOSX = case buildOS of OSX -> True; _ -> False-    isELF = case buildOS of OSX -> False; Windows -> False; _ -> True;+    isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True;     packageHacks = case compilerFlavor (compiler lbi) of       GHC   -> hackRtsPackage       GHCJS -> hackRtsPackage@@ -469,8 +452,8 @@ ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap`                               getDirectoryContentsRecursive buildBaseDir -ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppC2hs bi lbi =+ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppC2hs bi lbi clbi =   PreProcessor {     platformIndependent = False,     runPreProcessor = \(inBaseDir, inRelativeFile)@@ -484,7 +467,7 @@           -- Options from the current package:            [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]         ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]-        ++ [ "--cppopts=-include" ++ (autogenModulesDir lbi </> cppHeaderName) ]+        ++ [ "--cppopts=-include" ++ (autogenModulesDir lbi clbi </> cppHeaderName) ]         ++ [ "--include=" ++ outBaseDir ]            -- Options from dependent packages@@ -598,16 +581,16 @@       JavaScript  -> ["javascript"]       OtherArch _ -> [] -ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppHappy _ lbi = pp { platformIndependent = True }+ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppHappy _ lbi _ = pp { platformIndependent = True }   where pp = standardPP lbi happyProgram (hcFlags hc)         hc = compilerFlavor (compiler lbi)         hcFlags GHC = ["-agc"]         hcFlags GHCJS = ["-agc"]         hcFlags _ = [] -ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor-ppAlex _ lbi = pp { platformIndependent = True }+ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor+ppAlex _ lbi _ = pp { platformIndependent = True }   where pp = standardPP lbi alexProgram (hcFlags hc)         hc = compilerFlavor (compiler lbi)         hcFlags GHC = ["-g"]
cabal/Cabal/Distribution/Simple/Program.hs view
@@ -38,7 +38,8 @@     , ProgramSearchPath     , ProgramSearchPathEntry(..)     , simpleProgram-    , findProgramLocation+    , findProgramOnSearchPath+    , defaultProgramSearchPath     , findProgramVersion      -- * Configured program and related functions@@ -122,6 +123,7 @@     , rawSystemProgramConf     , rawSystemProgramStdoutConf     , findProgramOnPath+    , findProgramLocation      ) where @@ -129,11 +131,9 @@ import Distribution.Simple.Program.Run import Distribution.Simple.Program.Db import Distribution.Simple.Program.Builtin-+import Distribution.Simple.Program.Find import Distribution.Simple.Utils-         ( die, findProgramLocation, findProgramVersion ) import Distribution.Verbosity-         ( Verbosity )   -- | Runs the given configured program.@@ -217,6 +217,8 @@                                          -> ProgramConfiguration restoreProgramConfiguration = restoreProgramDb -{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-}+{-# DEPRECATED findProgramOnPath "use findProgramOnSearchPath instead" #-} findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath)-findProgramOnPath = flip findProgramLocation+findProgramOnPath name verbosity =+    fmap (fmap fst) $+    findProgramOnSearchPath verbosity defaultProgramSearchPath name
cabal/Cabal/Distribution/Simple/Program/Ar.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonoLocalBinds #-}  ----------------------------------------------------------------------------- -- |@@ -84,7 +85,8 @@         | inv <- multiStageProgramInvocation                    simple (initial, middle, final) files ] -  unless (hostArch == Arm) $ -- See #1537+  unless (hostArch == Arm -- See #1537+          || hostOS == AIX) $ -- AIX uses its own "ar" format variant     wipeMetadata tmpPath   equal <- filesEqual tmpPath targetPath   unless equal $ renameFile tmpPath targetPath
cabal/Cabal/Distribution/Simple/Program/Builtin.hs view
@@ -46,27 +46,16 @@   ) where  import Distribution.Simple.Program.Find-         ( findProgramOnSearchPath ) import Distribution.Simple.Program.Internal-         ( stripExtractVersion ) import Distribution.Simple.Program.Run-         ( getProgramInvocationOutput, programInvocation ) import Distribution.Simple.Program.Types-         ( Program(..), ConfiguredProgram(..), simpleProgram ) import Distribution.Simple.Utils-         ( findProgramVersion ) import Distribution.Compat.Exception-         ( catchIO ) import Distribution.Verbosity-         ( lessVerbose ) import Distribution.Version-         ( Version(..), withinRange, earlierVersion, laterVersion-         , intersectVersionRanges )+ import Data.Char          ( isDigit )--import Data.List-         ( isInfixOf ) import qualified Data.Map as Map  -- ------------------------------------------------------------@@ -227,16 +216,16 @@ haskellSuiteProgram = (simpleProgram "haskell-suite") {     -- pretend that the program exists, otherwise it won't be in the     -- "configured" state-    programFindLocation =-      \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location"+    programFindLocation = \_verbosity _searchPath ->+      return $ Just ("haskell-suite-dummy-location", [])   }  -- This represent a haskell-suite package manager. See the comments for -- haskellSuiteProgram. haskellSuitePkgProgram :: Program haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {-    programFindLocation =-      \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location"+    programFindLocation = \_verbosity _searchPath ->+      return $ Just ("haskell-suite-pkg-dummy-location", [])   }
cabal/Cabal/Distribution/Simple/Program/Db.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}- ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Db@@ -59,29 +56,19 @@   ) where  import Distribution.Simple.Program.Types-         ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) import Distribution.Simple.Program.Find-         ( ProgramSearchPath, defaultProgramSearchPath-         , findProgramOnSearchPath, programSearchPathAsPATHVar ) import Distribution.Simple.Program.Builtin-         ( builtinPrograms ) import Distribution.Simple.Utils-         ( die, doesExecutableExist ) import Distribution.Version-         ( Version, VersionRange, isAnyVersion, withinRange ) import Distribution.Text-         ( display ) import Distribution.Verbosity-         ( Verbosity )+import Distribution.Compat.Binary -import Distribution.Compat.Binary (Binary(..))-#if __GLASGOW_HASKELL__ < 710-import Data.Functor ((<$>))-#endif import Data.List          ( foldl' ) import Data.Maybe          ( catMaybes )+import Data.Tuple (swap) import qualified Data.Map as Map import Control.Monad          ( join, foldM )@@ -129,28 +116,42 @@   -- Read & Show instances are based on listToFM--- Note that we only serialise the configured part of the database, this is--- because we don't need the unconfigured part after the configure stage, and--- additionally because we cannot read/show 'Program' as it contains functions.++-- | Note that this instance does not preserve the known 'Program's.+-- See 'restoreProgramDb' for details.+-- instance Show ProgramDb where   show = show . Map.toAscList . configuredProgs +-- | Note that this instance does not preserve the known 'Program's.+-- See 'restoreProgramDb' for details.+-- instance Read ProgramDb where   readsPrec p s =     [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)     | (s', r) <- readsPrec p s ] +-- | Note that this instance does not preserve the known 'Program's.+-- See 'restoreProgramDb' for details.+-- instance Binary ProgramDb where-  put = put . configuredProgs+  put db = do+    put (progSearchPath db)+    put (configuredProgs db)+   get = do-      progs <- get-      return $! emptyProgramDb { configuredProgs = progs }+    searchpath <- get+    progs      <- get+    return $! emptyProgramDb {+      progSearchPath  = searchpath,+      configuredProgs = progs+    }  --- | The Read\/Show instance does not preserve all the unconfigured 'Programs'--- because 'Program' is not in Read\/Show because it contains functions. So to--- fully restore a deserialised 'ProgramDb' use this function to add--- back all the known 'Program's.+-- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the+-- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because+-- it contains functions. So to fully restore a deserialised 'ProgramDb' use+-- this function to add back all the known 'Program's. -- -- * It does not add the default programs, but you probably want them, use --   'builtinPrograms' in addition to any extra you might need.@@ -319,21 +320,23 @@ configureProgram verbosity prog conf = do   let name = programName prog   maybeLocation <- case userSpecifiedPath prog conf of-    Nothing   -> programFindLocation prog verbosity (progSearchPath conf)-             >>= return . fmap FoundOnSystem+    Nothing   ->+      programFindLocation prog verbosity (progSearchPath conf)+      >>= return . fmap (swap . fmap FoundOnSystem . swap)     Just path -> do       absolute <- doesExecutableExist path       if absolute-        then return (Just (UserSpecified path))+        then return (Just (UserSpecified path, []))         else findProgramOnSearchPath verbosity (progSearchPath conf) path-         >>= maybe (die notFound) (return . Just . UserSpecified)+             >>= maybe (die notFound)+                       (return . Just . swap . fmap UserSpecified . swap)       where notFound = "Cannot find the program '" ++ name                      ++ "'. User-specified path '"                      ++ path ++ "' does not refer to an executable and "                      ++ "the program is not on the system path."   case maybeLocation of     Nothing -> return conf-    Just location -> do+    Just (location, triedLocations) -> do       version <- programFindVersion prog verbosity (locationPath location)       newPath <- programSearchPathAsPATHVar (progSearchPath conf)       let configuredProg        = ConfiguredProgram {@@ -343,7 +346,8 @@             programOverrideArgs = userSpecifiedArgs prog conf,             programOverrideEnv  = [("PATH", Just newPath)],             programProperties   = Map.empty,-            programLocation     = location+            programLocation     = location,+            programMonitorFiles = triedLocations           }       configuredProg' <- programPostConf prog verbosity configuredProg       return (updateConfiguredProgs (Map.insert name configuredProg') conf)@@ -443,7 +447,7 @@           | otherwise                 ->             return $! Left (badVersion version location)         Nothing                       ->-          return $! Left (noVersion location)+          return $! Left (unknownVersion location)    where notFound       = "The program '"                       ++ programName prog ++ "'" ++ versionRequirement@@ -452,7 +456,7 @@                       ++ programName prog ++ "'" ++ versionRequirement                       ++ " is required but the version found at "                       ++ locationPath l ++ " is version " ++ display v-        noVersion l    = "The program '"+        unknownVersion l = "The program '"                       ++ programName prog ++ "'" ++ versionRequirement                       ++ " is required but the version of "                       ++ locationPath l ++ " could not be determined."@@ -467,5 +471,5 @@                       -> ProgramDb                       -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb =-  join $ either die return <$>+  join $ either die return `fmap`   lookupProgramVersion verbosity prog range programDb
cabal/Cabal/Distribution/Simple/Program/Find.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE CPP, DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- |--- Module      :  Distribution.Simple.Program.Types+-- Module      :  Distribution.Simple.Program.Find -- Copyright   :  Duncan Coutts 2013 -- -- Maintainer  :  cabal-devel@haskell.org@@ -26,23 +28,26 @@     defaultProgramSearchPath,     findProgramOnSearchPath,     programSearchPathAsPATHVar,+    getSystemSearchPath,   ) where  import Distribution.Verbosity-         ( Verbosity ) import Distribution.Simple.Utils-         ( debug, doesExecutableExist ) import Distribution.System-         ( OS(..), buildOS )-import System.Directory-         ( findExecutable ) import Distribution.Compat.Environment-         ( getEnvironment )-import System.FilePath-         ( (</>), (<.>), splitSearchPath, searchPathSeparator )-import Data.List-         ( intercalate )+import Distribution.Compat.Binary +import qualified System.Directory as Directory+         ( findExecutable )+import System.FilePath as FilePath+         ( (</>), (<.>), splitSearchPath, searchPathSeparator, getSearchPath+         , takeDirectory )+import Data.List+         ( nub )+import GHC.Generics+#if defined(mingw32_HOST_OS)+import qualified System.Win32 as Win32+#endif  -- | A search path to use when locating executables. This is analogous -- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use@@ -60,58 +65,69 @@ data ProgramSearchPathEntry =          ProgramSearchPathDir FilePath  -- ^ A specific dir        | ProgramSearchPathDefault       -- ^ The system default+  deriving (Eq, Generic) +instance Binary ProgramSearchPathEntry+ defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault]  findProgramOnSearchPath :: Verbosity -> ProgramSearchPath-                        -> FilePath -> IO (Maybe FilePath)+                        -> FilePath -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do     debug verbosity $ "Searching for " ++ prog ++ " in path."-    res <- tryPathElems searchpath+    res <- tryPathElems [] searchpath     case res of       Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")-      Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path)+      Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path)     return res   where-    tryPathElems []       = return Nothing-    tryPathElems (pe:pes) = do+    tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry]+                 -> IO (Maybe (FilePath, [FilePath]))+    tryPathElems _     []       = return Nothing+    tryPathElems tried (pe:pes) = do       res <- tryPathElem pe       case res of-        Nothing -> tryPathElems pes-        Just _  -> return res+        (Nothing,      notfoundat) -> tryPathElems (notfoundat : tried) pes+        (Just foundat, notfoundat) -> return (Just (foundat, alltried))+          where+            alltried = concat (reverse (notfoundat : tried)) +    tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath])     tryPathElem (ProgramSearchPathDir dir) =-        findFirstExe [ dir </> prog <.> ext | ext <- extensions ]-      where-        -- Possible improvement: on Windows, read the list of extensions from-        -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe;-        -- .bat; .cmd".-        extensions = case buildOS of-                       Windows -> ["", "exe"]-                       Ghcjs   -> ["", "exe"]-                       _       -> [""]+        findFirstExe [ dir </> prog <.> ext | ext <- exeExtensions ] -    tryPathElem ProgramSearchPathDefault = do-      -- 'findExecutable' doesn't check that the path really refers to an-      -- executable on Windows (at least with GHC < 7.8). See-      -- https://ghc.haskell.org/trac/ghc/ticket/2184-      mExe <- findExecutable prog+    -- On windows, getSystemSearchPath is not guaranteed 100% correct so we+    -- use findExecutable and then approximate the not-found-at locations.+    tryPathElem ProgramSearchPathDefault | buildOS == Windows = do+      mExe    <- findExecutable prog+      syspath <- getSystemSearchPath       case mExe of-        Just exe -> do-          exeExists <- doesExecutableExist exe-          if exeExists-            then return mExe-            else return Nothing-        _        -> return mExe+        Nothing ->+          let notfoundat = [ dir </> prog | dir <- syspath ] in+          return (Nothing, notfoundat) -    findFirstExe []     = return Nothing-    findFirstExe (f:fs) = do-      isExe <- doesExecutableExist f-      if isExe-        then return (Just f)-        else findFirstExe fs+        Just foundat -> do+          let founddir   = takeDirectory foundat+              notfoundat = [ dir </> prog+                           | dir <- takeWhile (/= founddir) syspath ]+          return (Just foundat, notfoundat) +    -- On other OSs we can just do the simple thing+    tryPathElem ProgramSearchPathDefault = do+      dirs <- getSystemSearchPath+      findFirstExe [ dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions ]++    findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath])+    findFirstExe = go []+      where+        go fs' []     = return (Nothing, reverse fs')+        go fs' (f:fs) = do+          isExe <- doesExecutableExist f+          if isExe+            then return (Just f, reverse fs')+            else go (f:fs') fs+ -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@.@@ -124,3 +140,46 @@     getEntries ProgramSearchPathDefault   = do       env <- getEnvironment       return (maybe [] splitSearchPath (lookup "PATH" env))++-- | Get the system search path. On Unix systems this is just the @$PATH@ env+-- var, but on windows it's a bit more complicated.+--+getSystemSearchPath :: IO [FilePath]+getSystemSearchPath = fmap nub $ do+#if defined(mingw32_HOST_OS)+    processdir <- takeDirectory `fmap` Win32.getModuleFileName Win32.nullHANDLE+    currentdir <- Win32.getCurrentDirectory+    systemdir  <- Win32.getSystemDirectory+    windowsdir <- Win32.getWindowsDirectory+    pathdirs   <- FilePath.getSearchPath+    let path = processdir : currentdir+             : systemdir  : windowsdir+             : pathdirs+    return path+#else+    FilePath.getSearchPath+#endif++#ifdef MIN_VERSION_directory+#if MIN_VERSION_directory(1,2,1)+#define HAVE_directory_121+#endif+#endif++findExecutable :: FilePath -> IO (Maybe FilePath)+#ifdef HAVE_directory_121+findExecutable = Directory.findExecutable+#else+findExecutable prog = do+      -- With directory < 1.2.1 'findExecutable' doesn't check that the path+      -- really refers to an executable.+      mExe <- Directory.findExecutable prog+      case mExe of+        Just exe -> do+          exeExists <- doesExecutableExist exe+          if exeExists+            then return mExe+            else return Nothing+        _     -> return mExe+#endif+
cabal/Cabal/Distribution/Simple/Program/GHC.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}+ module Distribution.Simple.Program.GHC (     GhcOptions(..),     GhcMode(..),@@ -13,25 +15,23 @@    ) where -import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) )+import Distribution.Compat.Semigroup as Semi+import Distribution.Simple.GHC.ImplInfo import Distribution.Package import Distribution.PackageDescription hiding (Flag) import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.Setup    ( Flag(..), flagToMaybe, fromFlagOrDefault,-                                      flagToList )+import Distribution.Simple.Setup import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run+import Distribution.System import Distribution.Text import Distribution.Verbosity-import Distribution.Utils.NubList   ( NubListR, fromNubListR )-import Language.Haskell.Extension   ( Language(..), Extension(..) )+import Distribution.Utils.NubList+import Language.Haskell.Extension +import GHC.Generics (Generic) import qualified Data.Map as M-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif-import Data.List ( intercalate )  -- | A structured set of GHC options/flags --@@ -74,18 +74,20 @@   -------------   -- Packages -  -- | The package key the modules will belong to; the @ghc -this-package-key@-  -- flag.-  ghcOptPackageKey   :: Flag PackageKey,+  -- | The unit ID the modules will belong to; the @ghc -this-unit-id@+  -- flag (or @-this-package-key@ or @-package-name@ on older+  -- versions of GHC).  This is a 'String' because we assume you've+  -- already figured out what the correct format for this string is+  -- (we need to handle backwards compatibility.)+  ghcOptThisUnitId   :: Flag String,    -- | GHC package databases to use, the @ghc -package-conf@ flag.   ghcOptPackageDBs    :: PackageDBStack, -  -- | The GHC packages to use. For compatability with old and new ghc, this-  -- requires both the short and long form of the package id;-  -- the @ghc -package@ or @ghc -package-id@ flags.+  -- | The GHC packages to bring into scope when compiling,+  -- the @ghc -package-id@ flags.   ghcOptPackages      ::-    NubListR (InstalledPackageId, PackageId, ModuleRenaming),+    NubListR (UnitId, ModuleRenaming),    -- | Start with a clean package set; the @ghc -hide-all-packages@ flag   ghcOptHideAllPackages :: Flag Bool,@@ -94,9 +96,6 @@   -- -no-auto-link-packages@ flag.   ghcOptNoAutoLinkPackages :: Flag Bool, -  -- | What packages are implementing the signatures-  ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))],-   -----------------   -- Linker stuff @@ -112,6 +111,10 @@   -- | OSX only: frameworks to link in; the @ghc -framework@ flag.   ghcOptLinkFrameworks :: NubListR String, +  -- | OSX only: Search path for frameworks to link in; the+  -- @ghc -framework-path@ flag.+  ghcOptLinkFrameworkDirs :: NubListR String,+   -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.   ghcOptNoLink :: Flag Bool, @@ -211,7 +214,7 @@   -- Modifies some of the GHC error messages.   ghcOptCabal         :: Flag Bool -} deriving Show+} deriving (Show, Generic)   data GhcMode = GhcModeCompile     -- ^ @ghc -c@@@ -239,17 +242,19 @@                  | GhcProfAutoExported  -- ^ @-fprof-auto-exported@  deriving (Show, Eq) -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO ()-runGHC verbosity ghcProg comp opts = do-  runProgramInvocation verbosity (ghcInvocation ghcProg comp opts)+runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform  -> GhcOptions+       -> IO ()+runGHC verbosity ghcProg comp platform opts = do+  runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts)  -ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation-ghcInvocation prog comp opts =-    programInvocation prog (renderGhcOptions comp opts)+ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions+              -> ProgramInvocation+ghcInvocation prog comp platform opts =+    programInvocation prog (renderGhcOptions comp platform opts) -renderGhcOptions :: Compiler -> GhcOptions -> [String]-renderGhcOptions comp opts+renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]+renderGhcOptions comp _platform@(Platform _arch os) opts   | compilerFlavor comp `notElem` [GHC, GHCJS] =     error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "     ++ "compiler flavor must be 'GHC' or 'GHCJS'!"@@ -274,8 +279,7 @@    , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) -  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal-                                 , flagBuildingCabalPkg implInfo ]+  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ]    ----------------   -- Compilation@@ -337,12 +341,10 @@   , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]   , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]   , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]-  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir-                                 , flagOutputDir implInfo ]+  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ]   , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]   , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]-  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir-                               , flagStubdir implInfo ]+  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ]    -----------------------   -- Source search path@@ -357,8 +359,6 @@   , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]   , concat [ [ "-optP-include", "-optP" ++ inc]            | inc <- flags ghcOptCppIncludes ]-  , [ "-#include \"" ++ inc ++ "\""-    | inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ]   , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]    -----------------@@ -367,7 +367,14 @@   , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]   , ["-l" ++ lib     | lib <- flags ghcOptLinkLibs ]   , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]-  , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]+  , if isOSX+    then concat [ ["-framework", fmwk]+                | fmwk <- flags ghcOptLinkFrameworks ]+    else []+  , if isOSX+    then concat [ ["-framework-path", path]+                | path <- flags ghcOptLinkFrameworkDirs ]+    else []   , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]   , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]   , concat [ [ "-optl-Wl,-rpath," ++ dir]@@ -376,32 +383,22 @@   -------------   -- Packages -  , concat [ [if packageKeySupported comp-                then "-this-package-key"-                else "-package-name", display pkgid]-             | pkgid <- flag ghcOptPackageKey ]+  , concat [ [ case () of+                _ | unitIdSupported comp     -> "-this-unit-id"+                  | packageKeySupported comp -> "-this-package-key"+                  | otherwise                -> "-package-name"+             , this_arg ]+             | this_arg <- flag ghcOptThisUnitId ]    , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]   , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]    , packageDbArgs implInfo (ghcOptPackageDBs opts) -  , if null (ghcOptSigOf opts)-        then []-        else "-sig-of"-             : intercalate "," (map (\(n,(p,m)) -> display n ++ " is "-                                                ++ display p ++ ":"-                                                ++ display m)-                                    (ghcOptSigOf opts))-             : []--  , concat $ if flagPackageId implInfo-      then let space "" = ""-               space xs = ' ' : xs-           in [ ["-package-id", display ipkgid ++ space (display rns)]-              | (ipkgid,_,rns) <- flags ghcOptPackages ]-      else [ ["-package",    display  pkgid]-           | (_,pkgid,_)  <- flags ghcOptPackages ]+  , concat $ let space "" = ""+                 space xs = ' ' : xs+             in [ ["-package-id", display ipkgid ++ space (display rns)]+                | (ipkgid,rns) <- flags ghcOptPackages ]    ----------------------------   -- Language and extensions@@ -441,6 +438,7 @@    where     implInfo     = getImplInfo comp+    isOSX        = os == OSX     flag     flg = flagToList (flg opts)     flags    flg = fromNubListR . flg $ opts     flagBool flg = fromFlagOrDefault False (flg opts)@@ -493,113 +491,8 @@ -- Boilerplate Monoid instance for GhcOptions  instance Monoid GhcOptions where-  mempty = GhcOptions {-    ghcOptMode               = mempty,-    ghcOptExtra              = mempty,-    ghcOptExtraDefault       = mempty,-    ghcOptInputFiles         = mempty,-    ghcOptInputModules       = mempty,-    ghcOptOutputFile         = mempty,-    ghcOptOutputDynFile      = mempty,-    ghcOptSourcePathClear    = mempty,-    ghcOptSourcePath         = mempty,-    ghcOptPackageKey         = mempty,-    ghcOptPackageDBs         = mempty,-    ghcOptPackages           = mempty,-    ghcOptHideAllPackages    = mempty,-    ghcOptNoAutoLinkPackages = mempty,-    ghcOptSigOf              = mempty,-    ghcOptLinkLibs           = mempty,-    ghcOptLinkLibPath        = mempty,-    ghcOptLinkOptions        = mempty,-    ghcOptLinkFrameworks     = mempty,-    ghcOptNoLink             = mempty,-    ghcOptLinkNoHsMain       = mempty,-    ghcOptCcOptions          = mempty,-    ghcOptCppOptions         = mempty,-    ghcOptCppIncludePath     = mempty,-    ghcOptCppIncludes        = mempty,-    ghcOptFfiIncludes        = mempty,-    ghcOptLanguage           = mempty,-    ghcOptExtensions         = mempty,-    ghcOptExtensionMap       = mempty,-    ghcOptOptimisation       = mempty,-    ghcOptDebugInfo          = mempty,-    ghcOptProfilingMode      = mempty,-    ghcOptProfilingAuto      = mempty,-    ghcOptSplitObjs          = mempty,-    ghcOptNumJobs            = mempty,-    ghcOptHPCDir             = mempty,-    ghcOptGHCiScripts        = mempty,-    ghcOptHiSuffix           = mempty,-    ghcOptObjSuffix          = mempty,-    ghcOptDynHiSuffix        = mempty,-    ghcOptDynObjSuffix       = mempty,-    ghcOptHiDir              = mempty,-    ghcOptObjDir             = mempty,-    ghcOptOutputDir          = mempty,-    ghcOptStubDir            = mempty,-    ghcOptDynLinkMode        = mempty,-    ghcOptShared             = mempty,-    ghcOptFPic               = mempty,-    ghcOptDylibName          = mempty,-    ghcOptRPaths             = mempty,-    ghcOptVerbosity          = mempty,-    ghcOptCabal              = mempty-  }-  mappend a b = GhcOptions {-    ghcOptMode               = combine ghcOptMode,-    ghcOptExtra              = combine ghcOptExtra,-    ghcOptExtraDefault       = combine ghcOptExtraDefault,-    ghcOptInputFiles         = combine ghcOptInputFiles,-    ghcOptInputModules       = combine ghcOptInputModules,-    ghcOptOutputFile         = combine ghcOptOutputFile,-    ghcOptOutputDynFile      = combine ghcOptOutputDynFile,-    ghcOptSourcePathClear    = combine ghcOptSourcePathClear,-    ghcOptSourcePath         = combine ghcOptSourcePath,-    ghcOptPackageKey         = combine ghcOptPackageKey,-    ghcOptPackageDBs         = combine ghcOptPackageDBs,-    ghcOptPackages           = combine ghcOptPackages,-    ghcOptHideAllPackages    = combine ghcOptHideAllPackages,-    ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,-    ghcOptSigOf              = combine ghcOptSigOf,-    ghcOptLinkLibs           = combine ghcOptLinkLibs,-    ghcOptLinkLibPath        = combine ghcOptLinkLibPath,-    ghcOptLinkOptions        = combine ghcOptLinkOptions,-    ghcOptLinkFrameworks     = combine ghcOptLinkFrameworks,-    ghcOptNoLink             = combine ghcOptNoLink,-    ghcOptLinkNoHsMain       = combine ghcOptLinkNoHsMain,-    ghcOptCcOptions          = combine ghcOptCcOptions,-    ghcOptCppOptions         = combine ghcOptCppOptions,-    ghcOptCppIncludePath     = combine ghcOptCppIncludePath,-    ghcOptCppIncludes        = combine ghcOptCppIncludes,-    ghcOptFfiIncludes        = combine ghcOptFfiIncludes,-    ghcOptLanguage           = combine ghcOptLanguage,-    ghcOptExtensions         = combine ghcOptExtensions,-    ghcOptExtensionMap       = combine ghcOptExtensionMap,-    ghcOptOptimisation       = combine ghcOptOptimisation,-    ghcOptDebugInfo          = combine ghcOptDebugInfo,-    ghcOptProfilingMode      = combine ghcOptProfilingMode,-    ghcOptProfilingAuto      = combine ghcOptProfilingAuto,-    ghcOptSplitObjs          = combine ghcOptSplitObjs,-    ghcOptNumJobs            = combine ghcOptNumJobs,-    ghcOptHPCDir             = combine ghcOptHPCDir,-    ghcOptGHCiScripts        = combine ghcOptGHCiScripts,-    ghcOptHiSuffix           = combine ghcOptHiSuffix,-    ghcOptObjSuffix          = combine ghcOptObjSuffix,-    ghcOptDynHiSuffix        = combine ghcOptDynHiSuffix,-    ghcOptDynObjSuffix       = combine ghcOptDynObjSuffix,-    ghcOptHiDir              = combine ghcOptHiDir,-    ghcOptObjDir             = combine ghcOptObjDir,-    ghcOptOutputDir          = combine ghcOptOutputDir,-    ghcOptStubDir            = combine ghcOptStubDir,-    ghcOptDynLinkMode        = combine ghcOptDynLinkMode,-    ghcOptShared             = combine ghcOptShared,-    ghcOptFPic               = combine ghcOptFPic,-    ghcOptDylibName          = combine ghcOptDylibName,-    ghcOptRPaths             = combine ghcOptRPaths,-    ghcOptVerbosity          = combine ghcOptVerbosity,-    ghcOptCabal              = combine ghcOptCabal-  }-    where-      combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>)++instance Semigroup GhcOptions where+  (<>) = gmappend
cabal/Cabal/Distribution/Simple/Program/HcPkg.hs view
@@ -11,58 +11,54 @@  module Distribution.Simple.Program.HcPkg (     HcPkgInfo(..),+    MultiInstance(..),      init,     invoke,     register,     reregister,+    registerMultiInstance,     unregister,+    recache,     expose,     hide,     dump,+    describe,     list,      -- * Program invocations     initInvocation,     registerInvocation,     reregisterInvocation,+    registerMultiInstanceInvocation,     unregisterInvocation,+    recacheInvocation,     exposeInvocation,     hideInvocation,     dumpInvocation,+    describeInvocation,     listInvocation,   ) where -import Prelude hiding (init)-import Distribution.Package-         ( PackageId, InstalledPackageId(..) )+import Distribution.Package hiding (installedUnitId) import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo(..)-         , showInstalledPackageInfo-         , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) import Distribution.ParseUtils import Distribution.Simple.Compiler-         ( PackageDB(..), PackageDBStack ) import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId) ) import Distribution.Simple.Program.Run-         ( ProgramInvocation(..), IOEncoding(..), programInvocation-         , runProgramInvocation, getProgramInvocationOutput ) import Distribution.Text-         ( display, simpleParse ) import Distribution.Simple.Utils-         ( die ) import Distribution.Verbosity-         ( Verbosity, deafening, silent ) import Distribution.Compat.Exception-         ( catchExit ) +import Prelude hiding (init) import Data.Char          ( isSpace ) import Data.List          ( stripPrefix ) import System.FilePath as FilePath-         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )+         ( (</>), (<.>)+         , splitPath, splitDirectories, joinPath, isPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix  -- | Information about the features and capabilities of an @hc-pkg@@@ -73,17 +69,29 @@   , noPkgDbStack    :: Bool -- ^ no package DB stack supported   , noVerboseFlag   :: Bool -- ^ hc-pkg does not support verbosity flags   , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db-  , useSingleFileDb :: Bool -- ^ requires single file package database+  , supportsDirDbs  :: Bool -- ^ supports directory style package databases+  , requiresDirDbs  :: Bool -- ^ requires directory style package databases+  , nativeMultiInstance  :: Bool -- ^ supports --enable-multi-instance flag+  , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache   } +-- | Whether or not use multi-instance functionality.+data MultiInstance = MultiInstance | NoMultiInstance+  deriving (Show, Read, Eq, Ord)+ -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} ---init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()-init hpi verbosity path =-  runProgramInvocation verbosity (initInvocation hpi verbosity path)+init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()+init hpi verbosity preferCompat path+  |  not (supportsDirDbs hpi)+ || (not (requiresDirDbs hpi) && preferCompat)+  = writeFile path "[]" +  | otherwise+  = runProgramInvocation verbosity (initInvocation hpi verbosity path)+ -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()@@ -118,7 +126,51 @@   runProgramInvocation verbosity     (reregisterInvocation hpi verbosity packagedb pkgFile) +registerMultiInstance :: HcPkgInfo -> Verbosity+                      -> PackageDBStack+                      -> InstalledPackageInfo+                      -> IO ()+registerMultiInstance hpi verbosity packagedbs pkgInfo+  | nativeMultiInstance hpi+  = runProgramInvocation verbosity+      (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo)) +    -- This is a trick. Older versions of GHC do not support the+    -- --enable-multi-instance flag for ghc-pkg register but it turns out that+    -- the same ability is available by using ghc-pkg recache. The recache+    -- command is there to support distro package managers that like to work+    -- by just installing files and running update commands, rather than+    -- special add/remove commands. So the way to register by this method is+    -- to write the package registration file directly into the package db and+    -- then call hc-pkg recache.+    --+  | recacheMultiInstance hpi+  = do let pkgdb = last packagedbs+       writeRegistrationFileDirectly hpi pkgdb pkgInfo+       recache hpi verbosity pkgdb++  | otherwise+  = die $ "HcPkg.registerMultiInstance: the compiler does not support "+       ++ "registering multiple instances of packages."++writeRegistrationFileDirectly :: HcPkgInfo+                              -> PackageDB+                              -> InstalledPackageInfo+                              -> IO ()+writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo+  | supportsDirDbs hpi+  = do let pkgfile = dir </> display (installedUnitId pkgInfo) <.> "conf"+       writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)++  | otherwise+  = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"++writeRegistrationFileDirectly _ _ _ =+    -- We don't know here what the dir for the global or user dbs are,+    -- if that's needed it'll require a bit more plumbing to support.+    die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"++ -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db]@@ -129,6 +181,16 @@     (unregisterInvocation hpi verbosity packagedb pkgid)  +-- | Call @hc-pkg@ to recache the registered packages.+--+-- > hc-pkg recache [--user | --global | --package-db]+--+recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()+recache hpi verbosity packagedb =+  runProgramInvocation verbosity+    (recacheInvocation hpi verbosity packagedb)++ -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db]@@ -138,7 +200,22 @@   runProgramInvocation verbosity     (exposeInvocation hpi verbosity packagedb pkgid) +-- | Call @hc-pkg@ to retrieve a specific package+--+-- > hc-pkg describe [pkgid] [--user | --global | --package-db]+--+describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]+describe hpi verbosity packagedb pid = do +  output <- getProgramInvocationOutput verbosity+              (describeInvocation hpi verbosity packagedb pid)+    `catchIO` \_ -> return ""++  case parsePackages output of+    Left ok -> return ok+    _       -> die $ "failed to parse output of '"+                  ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'"+ -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db]@@ -157,40 +234,40 @@    output <- getProgramInvocationOutput verbosity               (dumpInvocation hpi verbosity packagedb)-    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"+    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"    case parsePackages output of     Left ok -> return ok     _       -> die $ "failed to parse output of '"                   ++ programId (hcPkgProgram hpi) ++ " dump'" +parsePackages :: String -> Either [InstalledPackageInfo] [PError]+parsePackages str =+  let parsed = map parseInstalledPackageInfo' (splitPkgs str)+   in case [ msg | ParseFailed msg <- parsed ] of+        []   -> Left [   setUnitId+                       . maybe id mungePackagePaths (pkgRoot pkg)+                       $ pkg+                     | ParseOk _ pkg <- parsed ]+        msgs -> Right msgs   where-    parsePackages str =-      let parsed = map parseInstalledPackageInfo' (splitPkgs str)-       in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Left [   setInstalledPackageId-                           . maybe id mungePackagePaths (pkgRoot pkg)-                           $ pkg-                         | ParseOk _ pkg <- parsed ]-            msgs -> Right msgs-     parseInstalledPackageInfo' =       parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo -    --TODO: this could be a lot faster. We're doing normaliseLineEndings twice-    -- and converting back and forth with lines/unlines.-    splitPkgs :: String -> [String]-    splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines-      where-        -- Handle the case of there being no packages at all.-        checkEmpty [s] | all isSpace s = []-        checkEmpty ss                  = ss+--TODO: this could be a lot faster. We're doing normaliseLineEndings twice+-- and converting back and forth with lines/unlines.+splitPkgs :: String -> [String]+splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines+  where+    -- Handle the case of there being no packages at all.+    checkEmpty [s] | all isSpace s = []+    checkEmpty ss                  = ss -        splitWith :: (a -> Bool) -> [a] -> [[a]]-        splitWith p xs = ys : case zs of-                           []   -> []-                           _:ws -> splitWith p ws-          where (ys,zs) = break p xs+    splitWith :: (a -> Bool) -> [a] -> [[a]]+    splitWith p xs = ys : case zs of+                       []   -> []+                       _:ws -> splitWith p ws+      where (ys,zs) = break p xs  mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec@@ -230,26 +307,24 @@         _                                  -> Nothing  --- Older installed package info files did not have the installedPackageId+-- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID.-setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo-setInstalledPackageId pkginfo@InstalledPackageInfo {-                        installedPackageId = InstalledPackageId "",-                        sourcePackageId    = pkgid+setUnitId :: InstalledPackageInfo -> InstalledPackageInfo+setUnitId pkginfo@InstalledPackageInfo {+                        installedUnitId = SimpleUnitId (ComponentId ""),+                        sourcePackageId = pkgid                       }                     = pkginfo {-                        --TODO use a proper named function for the conversion-                        -- from source package id to installed package id-                        installedPackageId = InstalledPackageId (display pkgid)+                        installedUnitId = mkLegacyUnitId pkgid                       }-setInstalledPackageId pkginfo = pkginfo+setUnitId pkginfo = pkginfo   -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker.--- Note in particular that it does not include the 'InstalledPackageId', just+-- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. -- list :: HcPkgInfo -> Verbosity -> PackageDB@@ -258,7 +333,7 @@    output <- getProgramInvocationOutput verbosity               (listInvocation hpi verbosity packagedb)-    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"+    `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"    case parsePackageIds output of     Just ok -> return ok@@ -279,38 +354,36 @@     args = ["init", path]         ++ verbosityOpts hpi verbosity -registerInvocation, reregisterInvocation+registerInvocation, reregisterInvocation, registerMultiInstanceInvocation   :: HcPkgInfo -> Verbosity -> PackageDBStack   -> Either FilePath InstalledPackageInfo   -> ProgramInvocation-registerInvocation   = registerInvocation' "register"-reregisterInvocation = registerInvocation' "update"-+registerInvocation   = registerInvocation' "register" NoMultiInstance+reregisterInvocation = registerInvocation' "update"   NoMultiInstance+registerMultiInstanceInvocation = registerInvocation' "update" MultiInstance -registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack+registerInvocation' :: String -> MultiInstance+                    -> HcPkgInfo -> Verbosity -> PackageDBStack                     -> Either FilePath InstalledPackageInfo                     -> ProgramInvocation-registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =-    programInvocation (hcPkgProgram hpi) args-  where-    args = [cmdname, pkgFile]-        ++ (if noPkgDbStack hpi-              then [packageDbOpts hpi (last packagedbs)]-              else packageDbStackOpts hpi packagedbs)-        ++ verbosityOpts hpi verbosity+registerInvocation' cmdname multiInstance hpi+                    verbosity packagedbs pkgFileOrInfo =+    case pkgFileOrInfo of+      Left pkgFile ->+        programInvocation (hcPkgProgram hpi) (args pkgFile) -registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =-    (programInvocation (hcPkgProgram hpi) args) {-      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),-      progInvokeInputEncoding = IOEncodingUTF8-    }+      Right pkgInfo ->+        (programInvocation (hcPkgProgram hpi) (args "-")) {+          progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),+          progInvokeInputEncoding = IOEncodingUTF8+        }   where-    args = [cmdname, "-"]-        ++ (if noPkgDbStack hpi-              then [packageDbOpts hpi (last packagedbs)]-              else packageDbStackOpts hpi packagedbs)-        ++ verbosityOpts hpi verbosity-+    args file = [cmdname, file]+             ++ (if noPkgDbStack hpi+                   then [packageDbOpts hpi (last packagedbs)]+                   else packageDbStackOpts hpi packagedbs)+             ++ [ "--enable-multi-instance" | multiInstance == MultiInstance ]+             ++ verbosityOpts hpi verbosity  unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId                      -> ProgramInvocation@@ -320,6 +393,14 @@     ++ verbosityOpts hpi verbosity  +recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB+                  -> ProgramInvocation+recacheInvocation hpi verbosity packagedb =+  programInvocation (hcPkgProgram hpi) $+       ["recache", packageDbOpts hpi packagedb]+    ++ verbosityOpts hpi verbosity++ exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId                  -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid =@@ -327,6 +408,15 @@        ["expose", packageDbOpts hpi packagedb, display pkgid]     ++ verbosityOpts hpi verbosity +describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId+                   -> ProgramInvocation+describeInvocation hpi verbosity packagedbs pkgid =+  programInvocation (hcPkgProgram hpi) $+       ["describe", display pkgid]+    ++ (if noPkgDbStack hpi+          then [packageDbOpts hpi (last packagedbs)]+          else packageDbStackOpts hpi packagedbs)+    ++ verbosityOpts hpi verbosity  hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId                -> ProgramInvocation
cabal/Cabal/Distribution/Simple/Program/Hpc.hs view
@@ -13,14 +13,13 @@     , union     ) where -import Distribution.ModuleName ( ModuleName )+import Distribution.ModuleName import Distribution.Simple.Program.Run-         ( ProgramInvocation, programInvocation, runProgramInvocation )-import Distribution.Simple.Program.Types ( ConfiguredProgram(..) )-import Distribution.Text ( display )-import Distribution.Simple.Utils ( warn )-import Distribution.Verbosity ( Verbosity )-import Distribution.Version ( Version(..), orLaterVersion, withinRange )+import Distribution.Simple.Program.Types+import Distribution.Text+import Distribution.Simple.Utils+import Distribution.Verbosity+import Distribution.Version  -- | Invoke hpc with the given parameters. --
cabal/Cabal/Distribution/Simple/Program/Run.hs view
@@ -24,12 +24,9 @@   ) where  import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..), programPath ) import Distribution.Simple.Utils-         ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut-         , toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Verbosity-         ( Verbosity )+import Distribution.Compat.Environment  import Data.List          ( foldl', unfoldr )@@ -38,8 +35,6 @@          ( when ) import System.Exit          ( ExitCode(..), exitWith )-import Distribution.Compat.Environment-         ( getEnvironment )  -- | Represents a specific invocation of a specific program. --
cabal/Cabal/Distribution/Simple/Program/Script.hs view
@@ -17,9 +17,7 @@   ) where  import Distribution.Simple.Program.Run-         ( ProgramInvocation(..) ) import Distribution.System-         ( OS(..) )  import Data.Maybe          ( maybeToList )
cabal/Cabal/Distribution/Simple/Program/Strip.hs view
@@ -10,16 +10,13 @@ module Distribution.Simple.Program.Strip (stripLib, stripExe)        where -import Distribution.Simple.Program (ProgramConfiguration, lookupProgram-                                   , programVersion, rawSystemProgram-                                   , stripProgram)-import Distribution.Simple.Utils   (warn)-import Distribution.System         (Arch(..), Platform(..), OS (..), buildOS)-import Distribution.Verbosity      (Verbosity)-import Distribution.Version        (orLaterVersion, withinRange)+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.System+import Distribution.Verbosity+import Distribution.Version  import Control.Monad               (unless)-import Data.Version                (Version(..)) import System.FilePath             (takeBaseName)  runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()@@ -47,10 +44,11 @@ stripLib :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO () stripLib verbosity (Platform arch os) conf path = do   case os of-    OSX -> -- '--strip-unneeded' is not supported on OS X, iOS or+    OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or            -- Solaris. See #1630.            return ()     IOS -> return ()+    AIX -> return ()     Solaris -> return ()     Windows -> -- Stripping triggers a bug in 'strip.exe' for                -- libraries with lots identically named modules. See
cabal/Cabal/Distribution/Simple/Program/Types.hs view
@@ -33,14 +33,10 @@   ) where  import Distribution.Simple.Program.Find-         ( ProgramSearchPath, ProgramSearchPathEntry(..)-         , findProgramOnSearchPath ) import Distribution.Version-         ( Version ) import Distribution.Verbosity-         ( Verbosity )+import Distribution.Compat.Binary -import Distribution.Compat.Binary (Binary) import qualified Data.Map as Map import GHC.Generics (Generic) @@ -59,8 +55,13 @@        --        -- It is supplied with the prevailing search path which will typically        -- just be used as-is, but can be extended or ignored as needed.+       --+       -- For the purpose of change monitoring, in addition to the location+       -- where the program was found, it returns all the other places that+       -- were tried.+       --        programFindLocation :: Verbosity -> ProgramSearchPath-                              -> IO (Maybe FilePath),+                              -> IO (Maybe (FilePath, [FilePath])),         -- | Try to find the version of the program. For many programs this is        -- not possible or is not necessary so it's OK to return Nothing.@@ -108,9 +109,18 @@        programProperties :: Map.Map String String,         -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@-       programLocation :: ProgramLocation-     } deriving (Eq, Generic, Read, Show)+       programLocation :: ProgramLocation, +       -- | In addition to the 'programLocation' where the program was found,+       -- these are additional locations that were looked at. The combination+       -- of ths found location and these not-found locations can be used to+       -- monitor to detect when the re-configuring the program might give a+       -- different result (e.g. found in a different location).+       --+       programMonitorFiles :: [FilePath]+     }+  deriving (Eq, Generic, Read, Show)+ instance Binary ConfiguredProgram  -- | Where a program was found. Also tells us whether it's specified by user or@@ -160,5 +170,6 @@      programOverrideArgs = [],      programOverrideEnv  = [],      programProperties   = Map.empty,-     programLocation     = loc+     programLocation     = loc,+     programMonitorFiles = [] -- did not look in any other locations   }
cabal/Cabal/Distribution/Simple/Register.hs view
@@ -28,6 +28,10 @@     unregister,      initPackageDB,+    doesPackageDBExist,+    createPackageDB,+    deletePackageDB,+     invokeHcPkg,     registerPackage,     generateRegistrationInfo,@@ -37,10 +41,7 @@   ) where  import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , ComponentName(..), getComponentLocalBuildInfo-         , InstallDirs(..), absoluteInstallDirs )-import Distribution.Simple.BuildPaths (haddockName)+import Distribution.Simple.BuildPaths  import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS@@ -49,42 +50,25 @@ import qualified Distribution.Simple.HaskellSuite as HaskellSuite  import Distribution.Simple.Compiler-         ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor-         , PackageDB, PackageDBStack, absolutePackageDBPaths-         , registrationPackageDB ) import Distribution.Simple.Program-         ( ProgramConfiguration, runProgramInvocation ) import Distribution.Simple.Program.Script-         ( invocationAsSystemScript )-import           Distribution.Simple.Program.HcPkg (HcPkgInfo) import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Setup-         ( RegisterFlags(..), CopyDest(..)-         , fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.PackageDescription-         ( PackageDescription(..), Library(..), BuildInfo(..), libModules ) import Distribution.Package-         ( Package(..), packageName, InstalledPackageId(..)-         , getHSLibraryName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo, InstalledPackageInfo(InstalledPackageInfo)-         , showInstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Utils-         ( writeUTF8File, writeFileAtomic, setFileExecutable-         , die, notice, setupMessage, shortRelativePath ) import Distribution.System-         ( OS(..), buildOS ) import Distribution.Text-         ( display )-import Distribution.Version ( Version(..) ) import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )  import System.FilePath ((</>), (<.>), isAbsolute) import System.Directory-         ( getCurrentDirectory )+         ( getCurrentDirectory, removeDirectoryRecursive, removeFile+         , doesDirectoryExist, doesFileExist ) +import Data.Version import Control.Monad (when) import Data.Maybe          ( isJust, fromMaybe, maybeToList )@@ -98,24 +82,43 @@ register :: PackageDescription -> LocalBuildInfo          -> RegisterFlags -- ^Install in the user's database?; verbose          -> IO ()-register pkg@PackageDescription { library       = Just lib  } lbi regFlags+register pkg lbi regFlags =+    -- We do NOT register libraries outside of the inplace database+    -- if there is no public library, since no one else can use it+    -- usefully (they're not public.)  If we start supporting scoped+    -- packages, we'll have to relax this.+    when (hasPublicLib pkg) $+        let maybeRegister (CLib lib) _clbi =+                registerOne pkg lbi regFlags lib+            maybeRegister _comp _clbi = return ()+        in withAllComponentsInBuildOrder pkg lbi maybeRegister++registerOne :: PackageDescription -> LocalBuildInfo -> RegisterFlags+            -> Library+            -> IO ()+registerOne pkg lbi regFlags lib   = do-    let clbi = getComponentLocalBuildInfo lbi CLibName+    let clbi = getComponentLocalBuildInfo lbi (CLibName (libName lib))      absPackageDBs    <- absolutePackageDBPaths packageDbs+    -- TODO: registration info named base on LIBNAME!!!     installedPkgInfo <- generateRegistrationInfo                            verbosity pkg lib lbi clbi inplace reloc distPref                            (registrationPackageDB absPackageDBs) +    info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)+     when (fromFlag (regPrintId regFlags)) $ do-      putStrLn (display (IPI.installedPackageId installedPkgInfo))+      putStrLn (display (IPI.installedUnitId installedPkgInfo))       -- Three different modes:     case () of      _ | modeGenerateRegFile   -> writeRegistrationFile installedPkgInfo        | modeGenerateRegScript -> writeRegisterScript   installedPkgInfo-       | otherwise             -> registerPackage verbosity-                                    installedPkgInfo pkg lbi inplace packageDbs+       | otherwise             -> do+           setupMessage verbosity "Registering" (packageId pkg)+           registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.NoMultiInstance+                           packageDbs installedPkgInfo    where     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))@@ -136,7 +139,7 @@      writeRegistrationFile installedPkgInfo = do       notice verbosity ("Creating package registration file: " ++ regFile)-      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)+      writeUTF8File regFile (IPI.showInstalledPackageInfo installedPkgInfo)      writeRegisterScript installedPkgInfo =       case compilerFlavor (compiler lbi) of@@ -147,11 +150,7 @@                (compiler lbi) (withPrograms lbi)                (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs) -register _ _ regFlags = notice verbosity "No package to register"-  where-    verbosity = fromFlag (regVerbosity regFlags) - generateRegistrationInfo :: Verbosity                          -> PackageDescription                          -> Library@@ -166,59 +165,80 @@   --TODO: eliminate pwd!   pwd <- getCurrentDirectory -  --TODO: the method of setting the InstalledPackageId is compiler specific+  --TODO: the method of setting the UnitId is compiler specific   --      this aspect should be delegated to a per-compiler helper.   let comp = compiler lbi-  ipid <-+  abi_hash <-     case compilerFlavor comp of      GHC | compilerVersion comp >= Version [6,11] [] -> do-            s <- GHC.libAbiHash verbosity pkg lbi lib clbi-            return (InstalledPackageId (display (packageId pkg) ++ '-':s))+            fmap AbiHash $ GHC.libAbiHash verbosity pkg lbi lib clbi      GHCJS -> do-            s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi-            return (InstalledPackageId (display (packageId pkg) ++ '-':s))-     _other -> do-            return (InstalledPackageId (display (packageId pkg)))+            fmap AbiHash $ GHCJS.libAbiHash verbosity pkg lbi lib clbi+     _ -> return (AbiHash "")    installedPkgInfo <-     if inplace       then return (inplaceInstalledPackageInfo pwd distPref-                     pkg ipid lib lbi clbi)+                     pkg abi_hash lib lbi clbi)     else if reloc       then relocRegistrationInfo verbosity-                     pkg lib lbi clbi ipid packageDb+                     pkg lib lbi clbi abi_hash packageDb       else return (absoluteInstalledPackageInfo-                     pkg ipid lib lbi clbi)+                     pkg abi_hash lib lbi clbi)  -  return installedPkgInfo{ IPI.installedPackageId = ipid }+  return installedPkgInfo{ IPI.abiHash = abi_hash }  relocRegistrationInfo :: Verbosity                       -> PackageDescription                       -> Library                       -> LocalBuildInfo                       -> ComponentLocalBuildInfo-                      -> InstalledPackageId+                      -> AbiHash                       -> PackageDB                       -> IO InstalledPackageInfo-relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb =+relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =   case (compilerFlavor (compiler lbi)) of     GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb               return (relocatableInstalledPackageInfo-                        pkg ipid lib lbi clbi fs)+                        pkg abi_hash lib lbi clbi fs)     _   -> die "Distribution.Simple.Register.relocRegistrationInfo: \                \not implemented for this compiler" +initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath -> IO ()+initPackageDB verbosity comp progdb dbPath =+    createPackageDB verbosity comp progdb False dbPath+ -- | Create an empty package DB at the specified location.-initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath-                 -> IO ()-initPackageDB verbosity comp conf dbPath =-  case compilerFlavor comp of-    HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath-    _               -> withHcPkg "Distribution.Simple.Register.initPackageDB: \-                                 \not implemented for this compiler" comp conf-                                 (\hpi -> HcPkg.init hpi verbosity dbPath)+createPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> Bool+                -> FilePath -> IO ()+createPackageDB verbosity comp progdb preferCompat dbPath =+    case compilerFlavor comp of+      GHC   -> HcPkg.init (GHC.hcPkgInfo   progdb) verbosity preferCompat dbPath+      GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath+      LHC   -> HcPkg.init (LHC.hcPkgInfo   progdb) verbosity False dbPath+      UHC   -> return ()+      HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath+      _              -> die $ "Distribution.Simple.Register.createPackageDB: "+                           ++ "not implemented for this compiler" +doesPackageDBExist :: FilePath -> IO Bool+doesPackageDBExist dbPath = do+    -- currently one impl for all compiler flavours, but could change if needed+    dir_exists <- doesDirectoryExist dbPath+    if dir_exists+        then return True+        else doesFileExist dbPath++deletePackageDB :: FilePath -> IO ()+deletePackageDB dbPath = do+    -- currently one impl for all compiler flavours, but could change if needed+    dir_exists <- doesDirectoryExist dbPath+    if dir_exists+        then removeDirectoryRecursive dbPath+        else do file_exists <- doesFileExist dbPath+                when file_exists $ removeFile dbPath+ -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack@@ -228,7 +248,7 @@     (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)  withHcPkg :: String -> Compiler -> ProgramConfiguration-          -> (HcPkgInfo -> IO a) -> IO a+          -> (HcPkg.HcPkgInfo -> IO a) -> IO a withHcPkg name comp conf f =   case compilerFlavor comp of     GHC   -> f (GHC.hcPkgInfo conf)@@ -238,31 +258,29 @@                   \not implemented for this compiler")  registerPackage :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool+                -> Compiler+                -> ProgramConfiguration+                -> HcPkg.MultiInstance                 -> PackageDBStack+                -> InstalledPackageInfo                 -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do-  let msg = if inplace-            then "In-place registering"-            else "Registering"-  setupMessage verbosity msg (packageId pkg)-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs-    GHCJS -> GHCJS.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs-    LHC   -> LHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs-    UHC   -> UHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs+registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo =+  case compilerFlavor comp of+    GHC   -> GHC.registerPackage   verbosity progdb multiInstance packageDbs installedPkgInfo+    GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo+    _ | HcPkg.MultiInstance == multiInstance+          -> die "Registering multiple package instances is not yet supported for this compiler"+    LHC   -> LHC.registerPackage   verbosity      progdb packageDbs installedPkgInfo+    UHC   -> UHC.registerPackage   verbosity comp progdb packageDbs installedPkgInfo     JHC   -> notice verbosity "Registering for jhc (nothing to do)"     HaskellSuite {} ->-      HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs+      HaskellSuite.registerPackage verbosity      progdb packageDbs installedPkgInfo     _    -> die "Registering is not implemented for this compiler"  writeHcPkgRegisterScript :: Verbosity                          -> InstalledPackageInfo                          -> PackageDBStack-                         -> HcPkgInfo+                         -> HcPkg.HcPkgInfo                          -> IO () writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do   let invocation  = HcPkg.reregisterInvocation hpi Verbosity.normal@@ -289,17 +307,19 @@   :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to                                 -- absolute paths.   -> PackageDescription-  -> InstalledPackageId+  -> AbiHash   -> Library   -> LocalBuildInfo   -> ComponentLocalBuildInfo   -> InstallDirs FilePath   -> InstalledPackageInfo-generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs =-  InstalledPackageInfo {-    IPI.installedPackageId = ipid,-    IPI.sourcePackageId    = packageId   pkg,-    IPI.packageKey         = componentPackageKey clbi,+generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs =+  IPI.InstalledPackageInfo {+    IPI.sourcePackageId    = (packageId   pkg) {+                                pkgName = componentCompatPackageName clbi+                             },+    IPI.installedUnitId    = componentUnitId clbi,+    IPI.compatPackageKey   = componentCompatPackageKey clbi,     IPI.license            = license     pkg,     IPI.copyright          = copyright   pkg,     IPI.maintainer         = maintainer  pkg,@@ -310,12 +330,10 @@     IPI.synopsis           = synopsis    pkg,     IPI.description        = description pkg,     IPI.category           = category    pkg,+    IPI.abiHash            = abi_hash,     IPI.exposed            = libExposed  lib,-    IPI.exposedModules     = map fixupSelf (componentExposedModules clbi),+    IPI.exposedModules     = componentExposedModules clbi,     IPI.hiddenModules      = otherModules bi,-    IPI.instantiatedWith   = map (\(k,(p,n)) ->-                                   (k,IPI.OriginalModule (IPI.installedPackageId p) n))-                                 (instantiatedWith lbi),     IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,     IPI.importDirs         = [ libdir installDirs | hasModules ],     -- Note. the libsubdir and datasubdir templates have already been expanded@@ -325,7 +343,7 @@                                else                      extraLibDirs bi,     IPI.dataDir            = datadir installDirs,     IPI.hsLibraries        = if hasLibrary-                               then [getHSLibraryName (componentLibraryName clbi)]+                               then [getHSLibraryName (componentUnitId clbi)]                                else [],     IPI.extraLibraries     = extraLibs bi,     IPI.extraGHCiLibraries = extraGHCiLibs bi,@@ -336,8 +354,8 @@                                  -- We don't want cc-options to be propagated                                  -- to C compilations in other packages.     IPI.ldOptions          = ldOptions bi,-    IPI.frameworkDirs      = [],     IPI.frameworks         = frameworks bi,+    IPI.frameworkDirs      = extraFrameworkDirs bi,     IPI.haddockInterfaces  = [haddockdir installDirs </> haddockName pkg],     IPI.haddockHTMLs       = [htmldir installDirs],     IPI.pkgRoot            = Nothing@@ -350,18 +368,6 @@                             || (not (null (jsSources bi)) &&                                 compilerFlavor (compiler lbi) == GHCJS) -    -- Since we currently don't decide the InstalledPackageId of our package-    -- until just before we register, we didn't have one for the re-exports-    -- of modules defined within this package, so we used an empty one that-    -- we fill in here now that we know what it is. It's a bit of a hack,-    -- we ought really to decide the InstalledPackageId ahead of time.-    fixupSelf (IPI.ExposedModule n o o') =-        IPI.ExposedModule n (fmap fixupOriginalModule o)-                            (fmap fixupOriginalModule o')-    fixupOriginalModule (IPI.OriginalModule i m) = IPI.OriginalModule (fixupIpid i) m-    fixupIpid (InstalledPackageId []) = ipid-    fixupIpid x = x- -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. --@@ -370,19 +376,20 @@ inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree                             -> FilePath -- ^ location of the dist tree                             -> PackageDescription-                            -> InstalledPackageId+                            -> AbiHash                             -> Library                             -> LocalBuildInfo                             -> ComponentLocalBuildInfo                             -> InstalledPackageInfo-inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi =+inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi =     generalInstalledPackageInfo adjustRelativeIncludeDirs-                                pkg ipid lib lbi clbi installDirs+                                pkg abi_hash lib lbi clbi installDirs   where     adjustRelativeIncludeDirs = map (inplaceDir </>)+    libTargetDir = componentBuildDir lbi clbi     installDirs =-      (absoluteInstallDirs pkg lbi NoCopyDest) {-        libdir     = inplaceDir </> buildDir lbi,+      (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) {+        libdir     = inplaceDir </> libTargetDir,         datadir    = inplaceDir </> dataDir pkg,         docdir     = inplaceDocdir,         htmldir    = inplaceHtmldir,@@ -398,14 +405,14 @@ -- This function knows about the layout of installed packages. -- absoluteInstalledPackageInfo :: PackageDescription-                             -> InstalledPackageId+                             -> AbiHash                              -> Library                              -> LocalBuildInfo                              -> ComponentLocalBuildInfo                              -> InstalledPackageInfo-absoluteInstalledPackageInfo pkg ipid lib lbi clbi =+absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi =     generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg ipid lib lbi clbi installDirs+                                pkg abi_hash lib lbi clbi installDirs   where     -- For installed packages we install all include files into one dir,     -- whereas in the build tree they may live in multiple local dirs.@@ -413,19 +420,19 @@       | null (installIncludes bi) = []       | otherwise                 = [includedir installDirs]     bi = libBuildInfo lib-    installDirs = absoluteInstallDirs pkg lbi NoCopyDest+    installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest   relocatableInstalledPackageInfo :: PackageDescription-                                -> InstalledPackageId+                                -> AbiHash                                 -> Library                                 -> LocalBuildInfo                                 -> ComponentLocalBuildInfo                                 -> FilePath                                 -> InstalledPackageInfo-relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot =+relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot =     generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg ipid lib lbi clbi installDirs+                                pkg abi_hash lib lbi clbi installDirs   where     -- For installed packages we install all include files into one dir,     -- whereas in the build tree they may live in multiple local dirs.@@ -435,7 +442,7 @@     bi = libBuildInfo lib      installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)-                $ absoluteInstallDirs pkg lbi NoCopyDest+                $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest  -- ----------------------------------------------------------------------------- -- Unregistration
cabal/Cabal/Distribution/Simple/Setup.hs view
@@ -30,12 +30,12 @@ -- read and written from files. This would allow us to save configure flags in -- config files. -{-# LANGUAGE CPP #-}- module Distribution.Simple.Setup (    GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,+  configPrograms,+  AllowNewer(..),    AllowNewerDep(..),  isAllowNewer,   configAbsolutePaths, readPackageDbList, showPackageDbList,   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,@@ -56,6 +56,7 @@   configureArgs, configureOptions, configureCCompiler, configureLinker,   buildOptions, haddockOptions, installDirsOptions,   programConfigurationOptions, programConfigurationPaths',+  splitArgs,    defaultDistPref, optionDistPref, @@ -65,51 +66,34 @@   fromFlagOrDefault,   flagToMaybe,   flagToList,-  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where+  boolOpt, boolOpt', trueArg, falseArg,+  optionVerbosity, optionNumJobs, readPToMaybe ) where -import Distribution.Compiler ()+import Distribution.Compiler import Distribution.ReadE import Distribution.Text-         ( Text(..), display ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp-import Distribution.ModuleName-import Distribution.Package ( Dependency(..)-                            , PackageName-                            , InstalledPackageId )-import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )+import Distribution.Package+import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)-         , DebugInfoLevel(..), flagToDebugInfoLevel-         , OptimisationLevel(..), flagToOptimisationLevel-         , ProfDetailLevel(..), flagToProfDetailLevel-         , absolutePackageDBPath )+import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Utils-         ( wrapText, wrapLine, lowercase, intercalate )-import Distribution.Simple.Program (Program(..), ProgramConfiguration,-                             requireProgram,-                             programInvocation, progInvokePath, progInvokeArgs,-                             knownPrograms,-                             addKnownProgram, emptyProgramConfiguration,-                             haddockProgram, ghcProgram, gccProgram, ldProgram)+import Distribution.Simple.Program import Distribution.Simple.InstallDirs-         ( InstallDirs(..), CopyDest(..),-           PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity import Distribution.Utils.NubList--import Control.Monad (liftM) import Distribution.Compat.Binary (Binary)-import Data.List   ( sort )-import Data.Char   ( isSpace, isAlpha )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid ( Monoid(..) )-#endif-import GHC.Generics (Generic)+import Distribution.Compat.Semigroup as Semi +import Control.Applicative as A ( Applicative(..), (<*) )+import Control.Monad            ( liftM )+import Data.List                ( sort )+import Data.Maybe               ( listToMaybe )+import Data.Char                ( isSpace, isAlpha )+import GHC.Generics             ( Generic )+ -- FIXME Not sure where this should live defaultDistPref :: FilePath defaultDistPref = "dist"@@ -145,9 +129,12 @@  instance Monoid (Flag a) where   mempty = NoFlag-  _ `mappend` f@(Flag _) = f-  f `mappend` NoFlag     = f+  mappend = (Semi.<>) +instance Semigroup (Flag a) where+  _ <> f@(Flag _) = f+  f <> NoFlag     = f+ instance Bounded a => Bounded (Flag a) where   minBound = toFlag minBound   maxBound = toFlag maxBound@@ -202,7 +189,7 @@ data GlobalFlags = GlobalFlags {     globalVersion        :: Flag Bool,     globalNumericVersion :: Flag Bool-  }+  } deriving (Generic)  defaultGlobalFlags :: GlobalFlags defaultGlobalFlags  = GlobalFlags {@@ -227,8 +214,8 @@         align str = str ++ replicate (maxlen - length str) ' '       in          "Commands:\n"-      ++ unlines [ "  " ++ align name ++ "    " ++ description-                 | (name, description) <- cmdDescs ]+      ++ unlines [ "  " ++ align name ++ "    " ++ descr+                 | (name, descr) <- cmdDescs ]       ++ "\n"       ++ "For more information about a command use\n"       ++ "  " ++ pname ++ " COMMAND --help\n\n"@@ -253,20 +240,78 @@ emptyGlobalFlags = mempty  instance Monoid GlobalFlags where-  mempty = GlobalFlags {-    globalVersion        = mempty,-    globalNumericVersion = mempty-  }-  mappend a b = GlobalFlags {-    globalVersion        = combine globalVersion,-    globalNumericVersion = combine globalNumericVersion-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup GlobalFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------ +-- | Policy for relaxing upper bounds in dependencies. For example, given+-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper+-- bound and choose a version of 'array' that is greater or equal to 0.5? By+-- default the upper bounds are always strictly honored.+data AllowNewer =++  -- | Default: honor the upper bounds in all dependencies, never choose+  -- versions newer than allowed.+  AllowNewerNone++  -- | Ignore upper bounds in dependencies on the given packages.+  | AllowNewerSome [AllowNewerDep]++  -- | Ignore upper bounds in dependencies on all packages.+  | AllowNewerAll+  deriving (Eq, Read, Show, Generic)++-- | Dependencies can be relaxed either for all packages in the install plan, or+-- only for some packages.+data AllowNewerDep = AllowNewerDep PackageName+                   | AllowNewerDepScoped PackageName PackageName+                   deriving (Eq, Read, Show, Generic)++instance Text AllowNewerDep where+  disp (AllowNewerDep p0)          = disp p0+  disp (AllowNewerDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1++  parse = scopedP Parse.<++ normalP+    where+      scopedP = AllowNewerDepScoped `fmap` parse A.<* Parse.char ':' A.<*> parse+      normalP = AllowNewerDep       `fmap` parse++instance Binary AllowNewer+instance Binary AllowNewerDep++instance Semigroup AllowNewer where+  AllowNewerNone       <> r                    = r+  l@AllowNewerAll      <> _                    = l+  l@(AllowNewerSome _) <> AllowNewerNone       = l+  (AllowNewerSome   _) <> r@AllowNewerAll      = r+  (AllowNewerSome   a) <> (AllowNewerSome b)   = AllowNewerSome (a ++ b)++instance Monoid AllowNewer where+  mempty  = AllowNewerNone+  mappend = (Semi.<>)++-- | Convert 'AllowNewer' to a boolean.+isAllowNewer :: AllowNewer -> Bool+isAllowNewer AllowNewerNone     = False+isAllowNewer (AllowNewerSome _) = True+isAllowNewer AllowNewerAll      = True++allowNewerParser :: Parse.ReadP r (Maybe AllowNewer)+allowNewerParser =+  (Just . AllowNewerSome) `fmap` Parse.sepBy1 parse (Parse.char ',')++allowNewerPrinter :: (Maybe AllowNewer) -> [Maybe String]+allowNewerPrinter Nothing                      = []+allowNewerPrinter (Just AllowNewerNone)        = []+allowNewerPrinter (Just AllowNewerAll)         = [Nothing]+allowNewerPrinter (Just (AllowNewerSome pkgs)) = map (Just . display) $ pkgs+ -- | Flags to @configure@ command. -- -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'@@ -276,8 +321,8 @@     -- because the type of configure is constrained by the UserHooks.     -- when we change UserHooks next we should pass the initial     -- ProgramConfiguration directly and not via ConfigFlags-    configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may-                                                 -- run+    configPrograms_     :: Last' ProgramConfiguration, -- ^All programs that+                                                       -- @cabal@ may run      configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths     configProgramArgs   :: [(String, [String])], -- ^user specified programs args@@ -308,7 +353,10 @@                                                             -- paths     configScratchDir    :: Flag FilePath,     configExtraLibDirs  :: [FilePath],   -- ^ path to search for extra libraries+    configExtraFrameworkDirs :: [FilePath],   -- ^ path to search for extra+                                              -- frameworks (OS X only)     configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files+    configIPID          :: Flag String, -- ^ explicit IPID to be used      configDistPref :: Flag FilePath, -- ^"dist" prefix     configVerbosity :: Flag Verbosity, -- ^verbosity level@@ -320,8 +368,7 @@     configStripLibs :: Flag Bool,      -- ^Enable library stripping     configConstraints :: [Dependency], -- ^Additional constraints for                                        -- dependencies.-    configDependencies :: [(PackageName, InstalledPackageId)],-    configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))],+    configDependencies :: [(PackageName, UnitId)],       -- ^The packages depended on.     configConfigurationsFlags :: FlagAssignment,     configTests               :: Flag Bool, -- ^Enable test suite compilation@@ -334,12 +381,20 @@     configFlagError :: Flag String,       -- ^Halt and show an error message indicating an error in flag assignment     configRelocatable :: Flag Bool, -- ^ Enable relocatable package built-    configDebugInfo :: Flag DebugInfoLevel  -- ^ Emit debug info.+    configDebugInfo :: Flag DebugInfoLevel,  -- ^ Emit debug info.+    configAllowNewer :: Maybe AllowNewer+    -- ^ Ignore upper bounds on all or some dependencies. Wrapped in 'Maybe' to+    -- distinguish between "default" and "explicitly disabled".   }   deriving (Generic, Read, Show)  instance Binary ConfigFlags +-- | More convenient version of 'configPrograms'. Results in an+-- 'error' if internal invariant is violated.+configPrograms :: ConfigFlags -> ProgramConfiguration+configPrograms = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms_+ configAbsolutePaths :: ConfigFlags -> IO ConfigFlags configAbsolutePaths f =   (\v -> f { configPackageDBs = v })@@ -348,7 +403,7 @@  defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags {-    configPrograms     = progConf,+    configPrograms_    = pure progConf,     configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,     configVanillaLib   = Flag True,     configProfLib      = NoFlag,@@ -380,7 +435,8 @@     configExactConfiguration = Flag False,     configFlagError    = NoFlag,     configRelocatable  = Flag False,-    configDebugInfo    = Flag NoDebugInfo+    configDebugInfo    = Flag NoDebugInfo,+    configAllowNewer   = Nothing   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags@@ -573,11 +629,22 @@          configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v})          (reqArg' "PATH" (\x -> [x]) id) +      ,option "" ["ipid"]+         "Installed package ID to compile this package as"+         configIPID (\v flags -> flags {configIPID = v})+         (reqArgFlag "IPID")+       ,option "" ["extra-lib-dirs"]          "A list of directories to search for external libraries"          configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})          (reqArg' "PATH" (\x -> [x]) id) +      ,option "" ["extra-framework-dirs"]+         "A list of directories to search for external frameworks (OS X only)"+         configExtraFrameworkDirs+         (\v flags -> flags {configExtraFrameworkDirs = v})+         (reqArg' "PATH" (\x -> [x]) id)+       ,option "" ["extra-prog-path"]          "A list of directories to search for required programs (in addition to the normal search locations)"          configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})@@ -597,13 +664,6 @@                  (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))                  (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) -      ,option "" ["instantiate-with"]-         "A mapping of signature names to concrete module instantiations. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\""-         configInstantiateWith (\v flags -> flags { configInstantiateWith = v })-         (reqArg "NAME=PKG:MOD"-                 (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry))-                 (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p)))-       ,option "" ["tests"]          "dependency checking and compilation for test suites listed in the package description file."          configTests (\v flags -> flags { configTests = v })@@ -619,6 +679,13 @@          configLibCoverage (\v flags -> flags { configLibCoverage = v })          (boolOpt [] []) +      ,option [] ["allow-newer"]+       ("Ignore upper bounds in all dependencies or DEPS")+       configAllowNewer (\v flags -> flags { configAllowNewer = v})+       (optArg "DEPS"+        (readP_to_E ("Cannot parse the list of packages: " ++) allowNewerParser)+        (Just AllowNewerAll) allowNewerPrinter)+       ,option "" ["exact-configuration"]          "All direct dependencies and flags are provided on the command line."          configExactConfiguration@@ -667,33 +734,16 @@     showPackageDb (Just (SpecificPackageDB db)) = db  showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]-showProfDetailLevelFlag dl =-  case dl of-    NoFlag                           -> []-    Flag ProfDetailNone              -> ["none"]-    Flag ProfDetailDefault           -> ["default"]-    Flag ProfDetailExportedFunctions -> ["exported-functions"]-    Flag ProfDetailToplevelFunctions -> ["toplevel-functions"]-    Flag ProfDetailAllFunctions      -> ["all-functions"]-    Flag (ProfDetailOther other)     -> [other]-+showProfDetailLevelFlag NoFlag    = []+showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)+parseDependency :: Parse.ReadP r (PackageName, UnitId) parseDependency = do   x <- parse   _ <- Parse.char '='   y <- parse   return (x, y) -parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName))-parseHoleMapEntry = do-  x <- parse-  _ <- Parse.char '='-  y <- parse-  _ <- Parse.char '@'-  z <- parse-  return (x, (z, y))- installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions =   [ option "" ["prefix"]@@ -760,98 +810,12 @@ emptyConfigFlags = mempty  instance Monoid ConfigFlags where-  mempty = ConfigFlags {-    configPrograms      = error "FIXME: remove configPrograms",-    configProgramPaths  = mempty,-    configProgramArgs   = mempty,-    configProgramPathExtra = mempty,-    configHcFlavor      = mempty,-    configHcPath        = mempty,-    configHcPkg         = mempty,-    configVanillaLib    = mempty,-    configProfLib       = mempty,-    configSharedLib     = mempty,-    configDynExe        = mempty,-    configProfExe       = mempty,-    configProf          = mempty,-    configProfDetail    = mempty,-    configProfLibDetail = mempty,-    configConfigureArgs = mempty,-    configOptimization  = mempty,-    configProgPrefix    = mempty,-    configProgSuffix    = mempty,-    configInstallDirs   = mempty,-    configScratchDir    = mempty,-    configDistPref      = mempty,-    configVerbosity     = mempty,-    configUserInstall   = mempty,-    configPackageDBs    = mempty,-    configGHCiLib       = mempty,-    configSplitObjs     = mempty,-    configStripExes     = mempty,-    configStripLibs     = mempty,-    configExtraLibDirs  = mempty,-    configConstraints   = mempty,-    configDependencies  = mempty,-    configInstantiateWith     = mempty,-    configExtraIncludeDirs    = mempty,-    configConfigurationsFlags = mempty,-    configTests               = mempty,-    configCoverage         = mempty,-    configLibCoverage   = mempty,-    configExactConfiguration  = mempty,-    configBenchmarks          = mempty,-    configFlagError     = mempty,-    configRelocatable   = mempty,-    configDebugInfo     = mempty-  }-  mappend a b =  ConfigFlags {-    configPrograms      = configPrograms b,-    configProgramPaths  = combine configProgramPaths,-    configProgramArgs   = combine configProgramArgs,-    configProgramPathExtra = combine configProgramPathExtra,-    configHcFlavor      = combine configHcFlavor,-    configHcPath        = combine configHcPath,-    configHcPkg         = combine configHcPkg,-    configVanillaLib    = combine configVanillaLib,-    configProfLib       = combine configProfLib,-    configSharedLib     = combine configSharedLib,-    configDynExe        = combine configDynExe,-    configProfExe       = combine configProfExe,-    configProf          = combine configProf,-    configProfDetail    = combine configProfDetail,-    configProfLibDetail = combine configProfLibDetail,-    configConfigureArgs = combine configConfigureArgs,-    configOptimization  = combine configOptimization,-    configProgPrefix    = combine configProgPrefix,-    configProgSuffix    = combine configProgSuffix,-    configInstallDirs   = combine configInstallDirs,-    configScratchDir    = combine configScratchDir,-    configDistPref      = combine configDistPref,-    configVerbosity     = combine configVerbosity,-    configUserInstall   = combine configUserInstall,-    configPackageDBs    = combine configPackageDBs,-    configGHCiLib       = combine configGHCiLib,-    configSplitObjs     = combine configSplitObjs,-    configStripExes     = combine configStripExes,-    configStripLibs     = combine configStripLibs,-    configExtraLibDirs  = combine configExtraLibDirs,-    configConstraints   = combine configConstraints,-    configDependencies  = combine configDependencies,-    configInstantiateWith     = combine configInstantiateWith,-    configExtraIncludeDirs    = combine configExtraIncludeDirs,-    configConfigurationsFlags = combine configConfigurationsFlags,-    configTests               = combine configTests,-    configCoverage         = combine configCoverage,-    configLibCoverage         = combine configLibCoverage,-    configExactConfiguration  = combine configExactConfiguration,-    configBenchmarks          = combine configBenchmarks,-    configFlagError     = combine configFlagError,-    configRelocatable   = combine configRelocatable,-    configDebugInfo     = combine configDebugInfo-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup ConfigFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Copy flags -- ------------------------------------------------------------@@ -860,27 +824,39 @@ data CopyFlags = CopyFlags {     copyDest      :: Flag CopyDest,     copyDistPref  :: Flag FilePath,-    copyVerbosity :: Flag Verbosity+    copyVerbosity :: Flag Verbosity,+    -- This is the same hack as in 'buildArgs'.  But I (ezyang) don't+    -- think it's a hack, it's the right way to make hooks more robust+    copyArgs :: [String]   }-  deriving Show+  deriving (Show, Generic)  defaultCopyFlags :: CopyFlags defaultCopyFlags  = CopyFlags {     copyDest      = Flag NoCopyDest,     copyDistPref  = NoFlag,-    copyVerbosity = Flag normal+    copyVerbosity = Flag normal,+    copyArgs      = []   }  copyCommand :: CommandUI CopyFlags copyCommand = CommandUI   { commandName         = "copy"-  , commandSynopsis     = "Copy the files into the install locations."+  , commandSynopsis     = "Copy the files of all/specific components to install locations."   , commandDescription  = Just $ \_ -> wrapText $-          "Does not call register, and allows a prefix at install time. "+          "Components encompass executables and libraries."+       ++ "Does not call register, and allows a prefix at install time. "        ++ "Without the --destdir flag, configure determines location.\n"-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " copy [FLAGS]\n"+  , commandNotes        = Just $ \pname ->+       "Examples:\n"+        ++ "  " ++ pname ++ " build           "+        ++ "    All the components in the package\n"+        ++ "  " ++ pname ++ " build foo       "+        ++ "    A component (i.e. lib, exe, test suite)"+  , commandUsage        = usageAlternatives "copy" $+      [ "[FLAGS]"+      , "COMPONENTS [FLAGS]"+      ]   , commandDefaultFlags = defaultCopyFlags   , commandOptions      = \showOrParseArgs ->       [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })@@ -901,18 +877,12 @@ emptyCopyFlags = mempty  instance Monoid CopyFlags where-  mempty = CopyFlags {-    copyDest      = mempty,-    copyDistPref  = mempty,-    copyVerbosity = mempty-  }-  mappend a b = CopyFlags {-    copyDest      = combine copyDest,-    copyDistPref  = combine copyDistPref,-    copyVerbosity = combine copyVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup CopyFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------@@ -925,7 +895,7 @@     installInPlace    :: Flag Bool,     installVerbosity :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  defaultInstallFlags :: InstallFlags defaultInstallFlags  = InstallFlags {@@ -978,22 +948,12 @@ emptyInstallFlags = mempty  instance Monoid InstallFlags where-  mempty = InstallFlags{-    installPackageDB = mempty,-    installDistPref  = mempty,-    installUseWrapper = mempty,-    installInPlace    = mempty,-    installVerbosity = mempty-  }-  mappend a b = InstallFlags{-    installPackageDB = combine installPackageDB,-    installDistPref  = combine installDistPref,-    installUseWrapper = combine installUseWrapper,-    installInPlace    = combine installInPlace,-    installVerbosity = combine installVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup InstallFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * SDist flags -- ------------------------------------------------------------@@ -1006,7 +966,7 @@     sDistListSources :: Flag FilePath,     sDistVerbosity   :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags {@@ -1055,22 +1015,12 @@ emptySDistFlags = mempty  instance Monoid SDistFlags where-  mempty = SDistFlags {-    sDistSnapshot    = mempty,-    sDistDirectory   = mempty,-    sDistDistPref    = mempty,-    sDistListSources = mempty,-    sDistVerbosity   = mempty-  }-  mappend a b = SDistFlags {-    sDistSnapshot    = combine sDistSnapshot,-    sDistDirectory   = combine sDistDirectory,-    sDistDistPref    = combine sDistDistPref,-    sDistListSources = combine sDistListSources,-    sDistVerbosity   = combine sDistVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup SDistFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Register flags -- ------------------------------------------------------------@@ -1086,7 +1036,7 @@     regPrintId     :: Flag Bool,     regVerbosity   :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  defaultRegisterFlags :: RegisterFlags defaultRegisterFlags = RegisterFlags {@@ -1178,26 +1128,12 @@ emptyRegisterFlags = mempty  instance Monoid RegisterFlags where-  mempty = RegisterFlags {-    regPackageDB   = mempty,-    regGenScript   = mempty,-    regGenPkgConf  = mempty,-    regInPlace     = mempty,-    regPrintId     = mempty,-    regDistPref    = mempty,-    regVerbosity   = mempty-  }-  mappend a b = RegisterFlags {-    regPackageDB   = combine regPackageDB,-    regGenScript   = combine regGenScript,-    regGenPkgConf  = combine regGenPkgConf,-    regInPlace     = combine regInPlace,-    regPrintId     = combine regPrintId,-    regDistPref    = combine regDistPref,-    regVerbosity   = combine regVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup RegisterFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * HsColour flags -- ------------------------------------------------------------@@ -1210,7 +1146,7 @@     hscolourDistPref    :: Flag FilePath,     hscolourVerbosity   :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  emptyHscolourFlags :: HscolourFlags emptyHscolourFlags = mempty@@ -1226,24 +1162,12 @@   }  instance Monoid HscolourFlags where-  mempty = HscolourFlags {-    hscolourCSS         = mempty,-    hscolourExecutables = mempty,-    hscolourTestSuites  = mempty,-    hscolourBenchmarks  = mempty,-    hscolourDistPref    = mempty,-    hscolourVerbosity   = mempty-  }-  mappend a b = HscolourFlags {-    hscolourCSS         = combine hscolourCSS,-    hscolourExecutables = combine hscolourExecutables,-    hscolourTestSuites  = combine hscolourTestSuites,-    hscolourBenchmarks  = combine hscolourBenchmarks,-    hscolourDistPref    = combine hscolourDistPref,-    hscolourVerbosity   = combine hscolourVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup HscolourFlags where+  (<>) = gmappend+ hscolourCommand :: CommandUI HscolourFlags hscolourCommand = CommandUI   { commandName         = "hscolour"@@ -1303,6 +1227,7 @@     haddockHoogle       :: Flag Bool,     haddockHtml         :: Flag Bool,     haddockHtmlLocation :: Flag String,+    haddockForHackage   :: Flag Bool,     haddockExecutables  :: Flag Bool,     haddockTestSuites   :: Flag Bool,     haddockBenchmarks   :: Flag Bool,@@ -1315,7 +1240,7 @@     haddockKeepTempFiles:: Flag Bool,     haddockVerbosity    :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  defaultHaddockFlags :: HaddockFlags defaultHaddockFlags  = HaddockFlags {@@ -1324,6 +1249,7 @@     haddockHoogle       = Flag False,     haddockHtml         = Flag False,     haddockHtmlLocation = NoFlag,+    haddockForHackage   = Flag False,     haddockExecutables  = Flag False,     haddockTestSuites   = Flag False,     haddockBenchmarks   = Flag False,@@ -1389,6 +1315,11 @@    haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })    (reqArgFlag "URL") +  ,option "" ["for-hackage"]+   "Collection of flags to generate documentation suitable for upload to hackage"+   haddockForHackage (\v flags -> flags { haddockForHackage = v })+   trueArg+   ,option "" ["executables"]    "Run haddock for Executables targets"    haddockExecutables (\v flags -> flags { haddockExecutables = v })@@ -1446,44 +1377,12 @@ emptyHaddockFlags = mempty  instance Monoid HaddockFlags where-  mempty = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = mempty,-    haddockHoogle       = mempty,-    haddockHtml         = mempty,-    haddockHtmlLocation = mempty,-    haddockExecutables  = mempty,-    haddockTestSuites   = mempty,-    haddockBenchmarks   = mempty,-    haddockInternal     = mempty,-    haddockCss          = mempty,-    haddockHscolour     = mempty,-    haddockHscolourCss  = mempty,-    haddockContents     = mempty,-    haddockDistPref     = mempty,-    haddockKeepTempFiles= mempty,-    haddockVerbosity    = mempty-  }-  mappend a b = HaddockFlags {-    haddockProgramPaths = combine haddockProgramPaths,-    haddockProgramArgs  = combine haddockProgramArgs,-    haddockHoogle       = combine haddockHoogle,-    haddockHtml         = combine haddockHtml,-    haddockHtmlLocation = combine haddockHtmlLocation,-    haddockExecutables  = combine haddockExecutables,-    haddockTestSuites   = combine haddockTestSuites,-    haddockBenchmarks   = combine haddockBenchmarks,-    haddockInternal     = combine haddockInternal,-    haddockCss          = combine haddockCss,-    haddockHscolour     = combine haddockHscolour,-    haddockHscolourCss  = combine haddockHscolourCss,-    haddockContents     = combine haddockContents,-    haddockDistPref     = combine haddockDistPref,-    haddockKeepTempFiles= combine haddockKeepTempFiles,-    haddockVerbosity    = combine haddockVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup HaddockFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Clean flags -- ------------------------------------------------------------@@ -1493,7 +1392,7 @@     cleanDistPref  :: Flag FilePath,     cleanVerbosity :: Flag Verbosity   }-  deriving Show+  deriving (Show, Generic)  defaultCleanFlags :: CleanFlags defaultCleanFlags  = CleanFlags {@@ -1529,18 +1428,12 @@ emptyCleanFlags = mempty  instance Monoid CleanFlags where-  mempty = CleanFlags {-    cleanSaveConf  = mempty,-    cleanDistPref  = mempty,-    cleanVerbosity = mempty-  }-  mappend a b = CleanFlags {-    cleanSaveConf  = combine cleanSaveConf,-    cleanDistPref  = combine cleanDistPref,-    cleanVerbosity = combine cleanVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup CleanFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------@@ -1555,7 +1448,7 @@     -- UserHooks stop us from passing extra info in other ways     buildArgs :: [String]   }-  deriving Show+  deriving (Show, Generic)  {-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} buildVerbose :: BuildFlags -> Verbosity@@ -1630,24 +1523,12 @@ emptyBuildFlags = mempty  instance Monoid BuildFlags where-  mempty = BuildFlags {-    buildProgramPaths = mempty,-    buildProgramArgs = mempty,-    buildVerbosity   = mempty,-    buildDistPref    = mempty,-    buildNumJobs     = mempty,-    buildArgs        = mempty-  }-  mappend a b = BuildFlags {-    buildProgramPaths = combine buildProgramPaths,-    buildProgramArgs = combine buildProgramArgs,-    buildVerbosity   = combine buildVerbosity,-    buildDistPref    = combine buildDistPref,-    buildNumJobs     = combine buildNumJobs,-    buildArgs        = combine buildArgs-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup BuildFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * REPL Flags -- ------------------------------------------------------------@@ -1659,7 +1540,7 @@     replVerbosity   :: Flag Verbosity,     replReload      :: Flag Bool   }-  deriving Show+  deriving (Show, Generic)  defaultReplFlags :: ReplFlags defaultReplFlags  = ReplFlags {@@ -1671,22 +1552,12 @@   }  instance Monoid ReplFlags where-  mempty = ReplFlags {-    replProgramPaths = mempty,-    replProgramArgs = mempty,-    replVerbosity   = mempty,-    replDistPref    = mempty,-    replReload      = mempty-  }-  mappend a b = ReplFlags {-    replProgramPaths = combine replProgramPaths,-    replProgramArgs = combine replProgramArgs,-    replVerbosity   = combine replVerbosity,-    replDistPref    = combine replDistPref,-    replReload      = combine replReload-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup ReplFlags where+  (<>) = gmappend+ replCommand :: ProgramConfiguration -> CommandUI ReplFlags replCommand progConf = CommandUI   { commandName         = "repl"@@ -1759,7 +1630,7 @@ -- * Test flags -- ------------------------------------------------------------ -data TestShowDetails = Never | Failures | Always | Streaming+data TestShowDetails = Never | Failures | Always | Streaming | Direct     deriving (Eq, Ord, Enum, Bounded, Show)  knownTestShowDetails :: [TestShowDetails]@@ -1779,8 +1650,11 @@ --TODO: do we need this instance? instance Monoid TestShowDetails where     mempty = Never-    mappend a b = if a < b then b else a+    mappend = (Semi.<>) +instance Semigroup TestShowDetails where+    a <> b = if a < b then b else a+ data TestFlags = TestFlags {     testDistPref    :: Flag FilePath,     testVerbosity   :: Flag Verbosity,@@ -1790,7 +1664,7 @@     testKeepTix     :: Flag Bool,     -- TODO: think about if/how options are passed to test exes     testOptions     :: [PathTemplate]-  }+  } deriving (Generic)  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {@@ -1847,7 +1721,8 @@             ("'always': always show results of individual test cases. "              ++ "'never': never show results of individual test cases. "              ++ "'failures': show results of failing test cases. "-             ++ "'streaming': show results of test cases in real time.")+             ++ "'streaming': show results of test cases in real time."+             ++ "'direct': send results of test cases in real time; no log file.")             testShowDetails (\v flags -> flags { testShowDetails = v })             (reqArg "FILTER"                 (readP_to_E (\_ -> "--show-details flag expects one of "@@ -1881,26 +1756,12 @@ emptyTestFlags  = mempty  instance Monoid TestFlags where-  mempty = TestFlags {-    testDistPref    = mempty,-    testVerbosity   = mempty,-    testHumanLog    = mempty,-    testMachineLog  = mempty,-    testShowDetails = mempty,-    testKeepTix     = mempty,-    testOptions     = mempty-  }-  mappend a b = TestFlags {-    testDistPref    = combine testDistPref,-    testVerbosity   = combine testVerbosity,-    testHumanLog    = combine testHumanLog,-    testMachineLog  = combine testMachineLog,-    testShowDetails = combine testShowDetails,-    testKeepTix     = combine testKeepTix,-    testOptions     = combine testOptions-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup TestFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Benchmark flags -- ------------------------------------------------------------@@ -1909,7 +1770,7 @@     benchmarkDistPref  :: Flag FilePath,     benchmarkVerbosity :: Flag Verbosity,     benchmarkOptions   :: [PathTemplate]-  }+  } deriving (Generic)  defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags  = BenchmarkFlags {@@ -1968,18 +1829,12 @@ emptyBenchmarkFlags = mempty  instance Monoid BenchmarkFlags where-  mempty = BenchmarkFlags {-    benchmarkDistPref  = mempty,-    benchmarkVerbosity = mempty,-    benchmarkOptions   = mempty-  }-  mappend a b = BenchmarkFlags {-    benchmarkDistPref  = combine benchmarkDistPref,-    benchmarkVerbosity = combine benchmarkVerbosity,-    benchmarkOptions   = combine benchmarkOptions-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (Semi.<>) +instance Semigroup BenchmarkFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Shared options utils -- ------------------------------------------------------------@@ -2133,13 +1988,16 @@         _        -> case reads s of           [(n, "")]             | n < 1     -> Left "The number of jobs should be 1 or more."-            | n > 64    -> Left "You probably don't want that many jobs."             | otherwise -> Right (Just n)           _             -> Left "The jobs value should be a number or '$ncpus'"  -- ------------------------------------------------------------ -- * Other Utils -- ------------------------------------------------------------++readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]  -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@.
cabal/Cabal/Distribution/Simple/SrcDist.hs view
@@ -40,35 +40,20 @@    )  where -import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)-         , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..) )-import Distribution.PackageDescription.Check-         ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles )+import Distribution.PackageDescription hiding (Flag)+import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.Package-         ( PackageIdentifier(pkgVersion), Package(..), packageVersion )-import Distribution.ModuleName (ModuleName)+import Distribution.ModuleName import qualified Distribution.ModuleName as ModuleName import Distribution.Version-         ( Version(versionBranch) ) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , installOrdinaryFiles, installMaybeExecutableFiles-         , findFile, findFileWithExtension, findAllFilesWithExtension, matchFileGlob-         , withTempDirectory, defaultPackageDesc-         , die, warn, notice, info, setupMessage )-import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)-                                 , fromFlag, flagToMaybe)-import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes-                                      , preprocessComponent )+import Distribution.Simple.Setup+import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), withAllComponentsInBuildOrder )-import Distribution.Simple.BuildPaths ( autogenModuleName )-import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,-                                     runProgram, programProperties, tarProgram )+import Distribution.Simple.BuildPaths+import Distribution.Simple.Program import Distribution.Text-         ( display )+import Distribution.Verbosity  import Control.Monad(when, unless, forM) import Data.Char (toLower)@@ -78,7 +63,6 @@ import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) import System.Directory ( doesFileExist ) import System.IO (IOMode(WriteMode), hPutStrLn, withFile)-import Distribution.Verbosity (Verbosity) import System.FilePath          ( (</>), (<.>), dropExtension, isAbsolute ) @@ -169,19 +153,20 @@   fmap concat . sequence $   [     -- Library sources.-    withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->+    fmap concat+    . withAllLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->      allSourcesBuildInfo libBi pps modules      -- Executables sources.   , fmap concat-    . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do+    . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do        biSrcs  <- allSourcesBuildInfo exeBi pps []        mainSrc <- findMainExeFile exeBi pps mainPath        return (mainSrc:biSrcs)      -- Test suites sources.   , fmap concat-    . withTest $ \t -> do+    . withAllTest $ \t -> do        let bi  = testBuildInfo t        case testInterface t of          TestSuiteExeV10 _ mainPath -> do@@ -200,7 +185,7 @@      -- Benchmarks sources.   , fmap concat-    . withBenchmark $ \bm -> do+    . withAllBenchmark $ \bm -> do        let  bi = benchmarkBuildInfo bm        case benchmarkInterface bm of          BenchmarkExeV10 _ mainPath -> do@@ -229,7 +214,8 @@   , return (licenseFiles pkg_descr)      -- Install-include files.-  , withLib $ \ l -> do+  , fmap concat+    . withAllLib $ \ l -> do        let lbi = libBuildInfo l            relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)        mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)@@ -244,10 +230,10 @@   where     -- We have to deal with all libs and executables, so we have local     -- versions of these functions that ignore the 'buildable' attribute:-    withLib       action = maybe (return []) action (library pkg_descr)-    withExe       action = mapM action (executables pkg_descr)-    withTest      action = mapM action (testSuites pkg_descr)-    withBenchmark action = mapM action (benchmarks pkg_descr)+    withAllLib       action = mapM action (libraries pkg_descr)+    withAllExe       action = mapM action (executables pkg_descr)+    withAllTest      action = mapM action (testSuites pkg_descr)+    withAllBenchmark action = mapM action (benchmarks pkg_descr)   -- |Prepare a directory tree of source files.@@ -263,8 +249,8 @@   case mb_lbi of     Just lbi | not (null pps) -> do       let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }-      withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ ->-        preprocessComponent pkg_descr c lbi' True verbosity pps+      withAllComponentsInBuildOrder pkg_descr lbi' $ \c clbi ->+        preprocessComponent pkg_descr c lbi' clbi True verbosity pps     _ -> return ()    (ordinary, mExecutable)  <- listPackageSources verbosity pkg_descr0 pps@@ -325,7 +311,7 @@ filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $                                  mapAllBuildInfo filterAutogenModuleBI pkg_descr0   where-    mapLib f pkg = pkg { library = fmap f (library pkg) }+    mapLib f pkg = pkg { libraries = map f (libraries pkg) }     filterAutogenModuleLib lib = lib {       exposedModules = filter (/=autogenModule) (exposedModules lib)     }@@ -481,7 +467,7 @@ mapAllBuildInfo :: (BuildInfo -> BuildInfo)                 -> (PackageDescription -> PackageDescription) mapAllBuildInfo f pkg = pkg {-    library     = fmap mapLibBi (library pkg),+    libraries   = fmap mapLibBi (libraries pkg),     executables = fmap mapExeBi (executables pkg),     testSuites  = fmap mapTestBi (testSuites pkg),     benchmarks  = fmap mapBenchBi (benchmarks pkg)
cabal/Cabal/Distribution/Simple/Test.hs view
@@ -16,23 +16,17 @@     ) where  import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(buildable)-         , TestSuite(..)-         , TestSuiteInterface(..), testType, hasTests )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( markupPackage )+import Distribution.Simple.Compiler+import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, substPathTemplate-    , PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..), localLibraryName )-import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage )-import Distribution.Simple.UserHooks ( Args )+import Distribution.Simple.Setup+import Distribution.Simple.UserHooks import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log-import Distribution.Simple.Utils ( die, notice )-import Distribution.TestSuite ( Result(..) )+import Distribution.Simple.Utils+import Distribution.TestSuite import Distribution.Text  import Control.Monad ( when, unless, filterM )@@ -132,5 +126,5 @@     fromPathTemplate $ substPathTemplate env template     where         env = initialPathTemplateEnv-                (PD.package pkg_descr) (LBI.localLibraryName lbi)+                (PD.package pkg_descr) (LBI.localUnitId lbi)                 (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
cabal/Cabal/Distribution/Simple/Test/ExeV10.hs view
@@ -2,26 +2,22 @@        ( runTest        ) where -import Distribution.Compat.CreatePipe ( createPipe )-import Distribution.Compat.Environment ( getEnvironment )+import Distribution.Compat.CreatePipe+import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )+import Distribution.Simple.Build.PathsModule+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler+import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup-    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils-    ( die, notice, rawSystemIOWithEnv, addLibraryPath )-import Distribution.System ( Platform (..) )+import Distribution.System import Distribution.TestSuite import Distribution.Text-import Distribution.Verbosity ( normal )+import Distribution.Verbosity  import Control.Concurrent (forkIO) import Control.Monad ( unless, void, when )@@ -30,7 +26,7 @@     , getCurrentDirectory, removeDirectoryRecursive ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (</>), (<.>) )-import System.IO ( hGetContents, hPutStr, stdout )+import System.IO ( hGetContents, hPutStr, stdout, stderr )  runTest :: PD.PackageDescription         -> LBI.LocalBuildInfo@@ -63,16 +59,21 @@     -- Write summary notices indicating start of test suite     notice verbosity $ summarizeSuiteStart $ PD.testName suite -    (rOut, wOut) <- createPipe+    (wOut, wErr, logText) <- case details of+        Direct -> return (stdout, stderr, "")+        _ -> do+            (rOut, wOut) <- createPipe -    -- Read test executable's output lazily (returns immediately)-    logText <- hGetContents rOut-    -- Force the IO manager to drain the test output pipe-    void $ forkIO $ length logText `seq` return ()+            -- Read test executable's output lazily (returns immediately)+            logText <- hGetContents rOut+            -- Force the IO manager to drain the test output pipe+            void $ forkIO $ length logText `seq` return () -    -- '--show-details=streaming': print the log output in another thread-    when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText+            -- '--show-details=streaming': print the log output in another thread+            when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText +            return (wOut, wOut, logText)+     -- Run the test executable     let opts = map (testOption pkg_descr lbi suite)                    (testOptions flags)@@ -93,7 +94,7 @@      exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')                                -- these handles are automatically closed-                               Nothing (Just wOut) (Just wOut)+                               Nothing (Just wOut) (Just wErr)      -- Generate TestSuiteLog from executable exit code and a machine-     -- readable test log.@@ -112,12 +113,10 @@     -- Show the contents of the human-readable log file on the terminal     -- if there is a failure and/or detailed output is requested     let whenPrinting = when $-            (details > Never)-            && (not (suitePassed $ testLogs suiteLog) || details == Always)+            ( details == Always ||+              details == Failures && not (suitePassed $ testLogs suiteLog))             -- verbosity overrides show-details             && verbosity >= normal-            -- if streaming, we already printed the log-            && details /= Streaming     whenPrinting $ putStr $ unlines $ lines logText      -- Write summary notice to terminal indicating end of test suite@@ -163,6 +162,6 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++           [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
cabal/Cabal/Distribution/Simple/Test/LibV09.hs view
@@ -6,32 +6,27 @@        , writeSimpleTestStub        ) where -import Distribution.Compat.CreatePipe ( createPipe )-import Distribution.Compat.Environment ( getEnvironment )-import Distribution.Compat.TempFile ( openTempFile )-import Distribution.ModuleName ( ModuleName )+import Distribution.Compat.CreatePipe+import Distribution.Compat.Environment+import Distribution.Compat.Internal.TempFile+import Distribution.ModuleName import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )+import Distribution.Simple.Build.PathsModule+import Distribution.Simple.BuildPaths+import Distribution.Simple.Compiler+import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI import Distribution.Simple.Setup-    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage ) import Distribution.Simple.Test.Log import Distribution.Simple.Utils-    ( die, notice, rawSystemIOWithEnv, addLibraryPath )-import Distribution.System ( Platform (..) )+import Distribution.System import Distribution.TestSuite import Distribution.Text-import Distribution.Verbosity ( normal )+import Distribution.Verbosity -import Control.Concurrent (forkIO) import Control.Exception ( bracket )-import Control.Monad ( when, unless, void )+import Control.Monad ( when, unless ) import Data.Maybe ( mapMaybe ) import System.Directory     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist@@ -40,6 +35,7 @@ import System.Exit ( ExitCode(..), exitWith ) import System.FilePath ( (</>), (<.>) ) import System.IO ( hClose, hGetContents, hPutStr )+import System.Process (StdStream(..), waitForProcess)  runTest :: PD.PackageDescription         -> LBI.LocalBuildInfo@@ -74,22 +70,11 @@      suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do -        (rIn, wIn) <- createPipe         (rOut, wOut) <- createPipe -        -- Prepare standard input for test executable-        --appendFile tempInput $ show (tempInput, PD.testName suite)-        hPutStr wIn $ show (tempLog, PD.testName suite)-        hClose wIn--        -- Append contents of temporary log file to the final human--        -- readable log file-        logText <- hGetContents rOut-        -- Force the IO manager to drain the test output pipe-        void $ forkIO $ length logText `seq` return ()-         -- Run test executable-        _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags+        (Just wIn, _, _, process) <- do+                let opts = map (testOption pkg_descr lbi suite) $ testOptions flags                     dataDirPath = pwd </> PD.dataDir pkg_descr                     tixFile = pwd </> tixFilePath distPref way (PD.testName suite)                     pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)@@ -108,10 +93,23 @@                                              True False lbi clbi                                   return (addLibraryPath os paths shellEnv)                                 else return shellEnv-                rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')-                                   -- these handles are closed automatically-                                   (Just rIn) (Just wOut) (Just wOut)+                createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')+                                     -- these handles are closed automatically+                                     CreatePipe (UseHandle wOut) (UseHandle wOut) +        hPutStr wIn $ show (tempLog, PD.testName suite)+        hClose wIn++        -- Append contents of temporary log file to the final human-+        -- readable log file+        logText <- hGetContents rOut+        -- Force the IO manager to drain the test output pipe+        length logText `seq` return ()++        exitcode <- waitForProcess process+        unless (exitcode == ExitSuccess) $ do+            debug verbosity $ cmd ++ " returned " ++ show exitcode+         -- Generate final log file name         let finalLogName l = testLogDir                              </> testSuiteLogPath@@ -171,7 +169,7 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.localLibraryName lbi)+          (PD.package pkg_descr) (LBI.localUnitId lbi)           (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++           [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
cabal/Cabal/Distribution/Simple/Test/Log.hs view
@@ -11,18 +11,16 @@        , testSuiteLogPath        ) where -import Distribution.Package ( PackageId )+import Distribution.Package import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId )+import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate ) import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup ( TestShowDetails(..) )-import Distribution.Simple.Utils ( notice )-import Distribution.System ( Platform )-import Distribution.TestSuite ( Options, Result(..) )-import Distribution.Verbosity ( Verbosity )+import Distribution.Simple.Setup+import Distribution.Simple.Utils+import Distribution.System+import Distribution.TestSuite+import Distribution.Verbosity  import Control.Monad ( when ) import Data.Char ( toUpper )@@ -109,13 +107,13 @@                  -> String -- ^ test suite name                  -> TestLogs -- ^ test suite results                  -> FilePath-testSuiteLogPath template pkg_descr lbi name result =+testSuiteLogPath template pkg_descr lbi test_name result =     fromPathTemplate $ substPathTemplate env template     where         env = initialPathTemplateEnv-                (PD.package pkg_descr) (LBI.localLibraryName lbi)+                (PD.package pkg_descr) (LBI.localUnitId lbi)                 (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)-                ++  [ (TestSuiteNameVar, toPathTemplate name)+                ++  [ (TestSuiteNameVar, toPathTemplate test_name)                     , (TestSuiteResultVar, toPathTemplate $ resultString result)                     ]
cabal/Cabal/Distribution/Simple/UHC.hs view
@@ -16,15 +16,12 @@  module Distribution.Simple.UHC (     configure, getInstalledPackages,-    buildLib, buildExe, installLib, registerPackage+    buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath   ) where -import Control.Monad-import Data.List-import qualified Data.Map as M ( empty ) import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo-import Distribution.Package hiding (installedPackageId)+import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler as C@@ -35,10 +32,14 @@ import Distribution.Text import Distribution.Verbosity import Distribution.Version+import Distribution.System import Language.Haskell.Extension++import Control.Monad+import Data.List+import qualified Data.Map as M ( empty ) import System.Directory import System.FilePath-import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring@@ -91,14 +92,13 @@                      -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs conf = do   let compilerid = compilerId comp-  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"]+  systemPkgDir <- getGlobalPackageDir verbosity conf   userPkgDir   <- getUserPackageDir   let pkgDirs    = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)   -- putStrLn $ "pkgdirs: " ++ show pkgDirs-  -- call to "lines" necessary, because pkgdir contains an extra newline at the end-  pkgs <- liftM (map addBuiltinVersions . concat) .-          mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) .-          concatMap lines $ pkgDirs+  pkgs <- liftM (map addBuiltinVersions . concat) $+          mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d))+          pkgDirs   -- putStrLn $ "pkgs: " ++ show pkgs   let iPkgs =         map mkInstalledPackageInfo $@@ -107,9 +107,16 @@   -- putStrLn $ "installed pkgs: " ++ show iPkgs   return (fromList iPkgs) +getGlobalPackageDir :: Verbosity -> ProgramConfiguration -> IO FilePath+getGlobalPackageDir verbosity conf = do+    output <- rawSystemProgramStdoutConf verbosity+                uhcProgram conf ["--meta-pkgdir-system"]+    -- call to "lines" necessary, because pkgdir contains an extra newline at the end+    let [pkgdir] = lines output+    return pkgdir+ getUserPackageDir :: IO FilePath-getUserPackageDir =-  do+getUserPackageDir = do     homeDir <- getHomeDirectory     return $ homeDir </> ".cabal" </> "lib"  -- TODO: determine in some other way @@ -150,8 +157,8 @@ -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo mkInstalledPackageInfo p = emptyInstalledPackageInfo-  { installedPackageId = InstalledPackageId (display p),-    sourcePackageId    = p }+  { installedUnitId = mkLegacyUnitId p,+    sourcePackageId = p }   -- -----------------------------------------------------------------------------@@ -161,7 +168,7 @@                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do -  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]+  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)   userPkgDir   <- getUserPackageDir   let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)   let uhcArgs =    -- set package name@@ -183,7 +190,7 @@ buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Executable         -> ComponentLocalBuildInfo -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do-  systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"]+  systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)   userPkgDir   <- getUserPackageDir   let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi)   let uhcArgs =    -- common flags lib/exe@@ -216,7 +223,7 @@      -- search paths   ++ ["-i" ++ odir]   ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]-  ++ ["-i" ++ autogenModulesDir lbi]+  ++ ["-i" ++ autogenModulesDir lbi clbi]      -- cpp options   ++ ["--optP=" ++ opt | opt <- cppOptions bi]      -- output path@@ -236,8 +243,8 @@  installLib :: Verbosity -> LocalBuildInfo            -> FilePath -> FilePath -> FilePath-           -> PackageDescription -> Library -> IO ()-installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do+           -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()+installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do     -- putStrLn $ "dest:  " ++ targetDir     -- putStrLn $ "built: " ++ builtDir     installDirectoryContents verbosity (builtDir </> display (packageId pkg)) targetDir@@ -258,19 +265,23 @@  registerPackage   :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool+  -> Compiler+  -> ProgramConfiguration   -> PackageDBStack+  -> InstalledPackageInfo   -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do-    let installDirs = absoluteInstallDirs pkg lbi NoCopyDest-        pkgdir  | inplace   = buildDir lbi       </> uhcPackageDir    (display pkgid) (display compilerid)-                | otherwise = libdir installDirs </> uhcPackageSubDir                 (display compilerid)+registerPackage verbosity comp progdb packageDbs installedPkgInfo = do+    dbdir <- case last packageDbs of+      GlobalPackageDB       -> getGlobalPackageDir verbosity progdb+      UserPackageDB         -> getUserPackageDir+      SpecificPackageDB dir -> return dir+    let pkgdir = dbdir </> uhcPackageDir (display pkgid) (display compilerid)     createDirectoryIfMissingVerbose verbosity True pkgdir     writeUTF8File (pkgdir </> installedPkgConfig)                   (showInstalledPackageInfo installedPkgInfo)   where-    pkgid      = packageId pkg-    compilerid = compilerId (compiler lbi)+    pkgid      = sourcePackageId installedPkgInfo+    compilerid = compilerId comp++inplacePackageDbPath :: LocalBuildInfo -> FilePath+inplacePackageDbPath lbi = buildDir lbi
cabal/Cabal/Distribution/Simple/UserHooks.hs view
@@ -29,16 +29,11 @@   ) where  import Distribution.PackageDescription-         (PackageDescription, GenericPackageDescription,-          HookedBuildInfo, emptyHookedBuildInfo)-import Distribution.Simple.Program    (Program)-import Distribution.Simple.Command    (noExtraFlags)-import Distribution.Simple.PreProcess (PPSuffixHandler)+import Distribution.Simple.Program+import Distribution.Simple.Command+import Distribution.Simple.PreProcess import Distribution.Simple.Setup-         (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags,-          InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,-          HaddockFlags, TestFlags, BenchmarkFlags)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)+import Distribution.Simple.LocalBuildInfo  type Args = [String] @@ -178,7 +173,7 @@       preClean  = rn,       cleanHook = ru,       postClean = ru,-      preCopy   = rn,+      preCopy   = rn',       copyHook  = ru,       postCopy  = ru,       preInst   = rn,
cabal/Cabal/Distribution/Simple/Utils.hs view
@@ -26,6 +26,9 @@         debugNoWrap, chattyTry,         printRawCommandAndArgs, printRawCommandAndArgsAndEnv, +        -- * exceptions+        handleDoesNotExist,+         -- * running programs         rawSystemExit,         rawSystemExitCode,@@ -33,6 +36,7 @@         rawSystemStdout,         rawSystemStdInOut,         rawSystemIOWithEnv,+        createProcessWithEnv,         maybeExit,         xargs,         findProgramLocation,@@ -64,6 +68,8 @@         -- * file names         currentDir,         shortRelativePath,+        dropExeExtension,+        exeExtensions,          -- * finding files         findFile,@@ -131,12 +137,37 @@         listUnionRight,         ordNub,         ordNubRight,+        safeTail,         wrapText,         wrapLine,   ) where +import Distribution.Text+import Distribution.Package+import Distribution.ModuleName as ModuleName+import Distribution.System+import Distribution.Version+import Distribution.Compat.CopyFile+import Distribution.Compat.Internal.TempFile+import Distribution.Compat.Exception+import Distribution.Verbosity++#if __GLASGOW_HASKELL__ < 711+#ifdef VERSION_base+#define BOOTSTRAPPED_CABAL 1+#endif+#else+#ifdef CURRENT_PACKAGE_KEY+#define BOOTSTRAPPED_CABAL 1+#endif+#endif++#ifdef BOOTSTRAPPED_CABAL+import qualified Paths_Cabal (version)+#endif+ import Control.Monad-    ( join, when, unless, filterM )+    ( when, unless, filterM ) import Control.Concurrent.MVar     ( newEmptyMVar, putMVar, takeMVar ) import Data.Bits@@ -146,9 +177,11 @@ import Data.Foldable     ( traverse_ ) import Data.List-    ( nub, unfoldr, isPrefixOf, tails, intercalate )+    ( nub, unfoldr, intercalate, isInfixOf ) import Data.Typeable     ( cast )+import Data.Ord+    ( comparing ) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.Set as Set@@ -181,40 +214,17 @@     ( unsafeInterleaveIO ) import qualified Control.Exception as Exception -import Distribution.Text-    ( display, simpleParse )-import Distribution.Package-    ( PackageIdentifier )-import Distribution.ModuleName (ModuleName)-import qualified Distribution.ModuleName as ModuleName-import Distribution.System-    ( OS (..) )-import Distribution.Version-    (Version(..))- import Control.Exception (IOException, evaluate, throwIO) import Control.Concurrent (forkIO) import qualified System.Process as Process          ( CreateProcess(..), StdStream(..), proc) import System.Process-         ( createProcess, rawSystem, runInteractiveProcess+         ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess          , showCommandForUser, waitForProcess)-import Distribution.Compat.CopyFile-         ( copyFile, copyOrdinaryFile, copyExecutableFile-         , setFileOrdinary, setFileExecutable, setDirOrdinary )-import Distribution.Compat.TempFile-         ( openTempFile, createTempDirectory )-import Distribution.Compat.Exception-         ( tryIO, catchIO, catchExit )-import Distribution.Verbosity -#ifdef VERSION_base-import qualified Paths_Cabal (version)-#endif- -- We only get our own version number when we're building with ourselves cabalVersion :: Version-#if defined(VERSION_base)+#if defined(BOOTSTRAPPED_CABAL) cabalVersion = Paths_Cabal.version #elif defined(CABAL_VERSION) cabalVersion = Version [CABAL_VERSION] []@@ -258,7 +268,7 @@     handle se = do       hFlush stdout       pname <- getProgName-      hPutStr stderr (message pname se)+      hPutStr stderr (wrapText (message pname se))       cont se      message :: String -> Exception.SomeException -> String@@ -272,7 +282,7 @@                                l@(n:_) | Char.isDigit n -> ':' : l                                _                        -> ""               detail       = ioeGetErrorString ioe-          in wrapText (pname ++ ": " ++ file ++ detail)+          in pname ++ ": " ++ file ++ detail         Nothing -> #if __GLASGOW_HASKELL__ < 710           show se@@ -345,6 +355,14 @@   catchIO action $ \exception ->     putStrLn $ "Error while " ++ desc ++ ": " ++ show exception +-- | Run an IO computation, returning @e@ if it raises a "file+-- does not exist" error.+handleDoesNotExist :: a -> IO a -> IO a+handleDoesNotExist e =+    Exception.handleJust+      (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)+      (\_ -> return e)+ -- ----------------------------------------------------------------------------- -- Helper functions @@ -450,29 +468,47 @@                    -> Maybe Handle  -- ^ stderr                    -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do+    (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv+                                       (mbToStd inp) (mbToStd out) (mbToStd err)+    exitcode <- waitForProcess ph+    unless (exitcode == ExitSuccess) $ do+      debug verbosity $ path ++ " returned " ++ show exitcode+    return exitcode+  where+    mbToStd :: Maybe Handle -> Process.StdStream+    mbToStd = maybe Process.Inherit Process.UseHandle++createProcessWithEnv ::+  Verbosity+  -> FilePath+  -> [String]+  -> Maybe FilePath           -- ^ New working dir or inherit+  -> Maybe [(String, String)] -- ^ New environment or inherit+  -> Process.StdStream  -- ^ stdin+  -> Process.StdStream  -- ^ stdout+  -> Process.StdStream  -- ^ stderr+  -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)+  -- ^ Any handles created for stdin, stdout, or stderr+  -- with 'CreateProcess', and a handle to the process.+createProcessWithEnv verbosity path args mcwd menv inp out err = do     printRawCommandAndArgsAndEnv verbosity path args menv     hFlush stdout-    (_,_,_,ph) <- createProcess $-                  (Process.proc path args) { Process.cwd           = mcwd-                                           , Process.env           = menv-                                           , Process.std_in        = mbToStd inp-                                           , Process.std_out       = mbToStd out-                                           , Process.std_err       = mbToStd err+    (inp', out', err', ph) <- createProcess $+                                (Process.proc path args) {+                                    Process.cwd           = mcwd+                                  , Process.env           = menv+                                  , Process.std_in        = inp+                                  , Process.std_out       = out+                                  , Process.std_err       = err #ifdef MIN_VERSION_process #if MIN_VERSION_process(1,2,0) -- delegate_ctlc has been added in process 1.2, and we still want to be able to -- bootstrap GHC on systems not having that version-                                           , Process.delegate_ctlc = True+                                  , Process.delegate_ctlc = True #endif #endif-                                           }-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-      debug verbosity $ path ++ " returned " ++ show exitcode-    return exitcode-  where-    mbToStd :: Maybe Handle -> Process.StdStream-    mbToStd = maybe Process.Inherit Process.UseHandle+                                  }+    return (inp', out', err', ph)  -- | Run a command and return its output. --@@ -554,6 +590,8 @@       return (out, err, exitcode)  +{-# DEPRECATED findProgramLocation+    "No longer used within Cabal, try findProgramOnSearchPath" #-} -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgramLocation verbosity prog = do@@ -699,12 +737,12 @@                -> [String]    -- ^ search suffixes                -> ModuleName  -- ^ module                -> IO (FilePath, FilePath)-findModuleFile searchPath extensions moduleName =+findModuleFile searchPath extensions mod_name =       maybe notFound return   =<< findFileWithExtension' extensions searchPath-                             (ModuleName.toFilePath moduleName)+                             (ModuleName.toFilePath mod_name)   where-    notFound = die $ "Error: Could not find module: " ++ display moduleName+    notFound = die $ "Error: Could not find module: " ++ display mod_name                   ++ " with any suffix: " ++ show extensions                   ++ " in the search path: " ++ show searchPath @@ -998,7 +1036,8 @@ copyDirectoryRecursive verbosity srcDir destDir = do   info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")   srcFiles <- getDirectoryContentsRecursive srcDir-  copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) | f <- srcFiles ]+  copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)+                                                   | f <- srcFiles ]  ------------------- -- File permissions@@ -1060,7 +1099,8 @@   Exception.bracket     (openTempFile tmpDir template)     (\(name, handle) -> do hClose handle-                           unless (optKeepTempFiles opts) $ removeFile name)+                           unless (optKeepTempFiles opts) $+                             handleDoesNotExist () . removeFile $ name)     (uncurry action)  -- | Create and use a temporary directory.@@ -1086,7 +1126,8 @@ withTempDirectoryEx _verbosity opts targetDir template =   Exception.bracket     (createTempDirectory targetDir template)-    (unless (optKeepTempFiles opts) . removeDirectoryRecursive)+    (unless (optKeepTempFiles opts)+     . handleDoesNotExist () . removeDirectoryRecursive)  ----------------------------------- -- Safely reading and writing files@@ -1153,6 +1194,24 @@         | x == y    = dropCommonPrefix xs ys     dropCommonPrefix xs ys = (xs,ys) +-- | Drop the extension if it's one of 'exeExtensions', or return the path+-- unchanged.+dropExeExtension :: FilePath -> FilePath+dropExeExtension filepath =+  case splitExtension filepath of+    (filepath', extension) | extension `elem` exeExtensions -> filepath'+                           | otherwise                      -> filepath++-- | List of possible executable file extensions on the current platform.+exeExtensions :: [String]+exeExtensions = case buildOS of+  -- Possible improvement: on Windows, read the list of extensions from the+  -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;+  -- .cmd".+  Windows -> ["", "exe"]+  Ghcjs   -> ["", "exe"]+  _       -> [""]+ -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------@@ -1191,7 +1250,7 @@  -- |Like 'findPackageDesc', but calls 'die' in case of error. tryFindPackageDesc :: FilePath -> IO FilePath-tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir+tryFindPackageDesc dir = either die return =<< findPackageDesc dir  -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath)@@ -1415,14 +1474,13 @@   where     bSet = Set.fromList b +-- | A total variant of 'tail'.+safeTail :: [a] -> [a]+safeTail []     = []+safeTail (_:xs) = xs+ equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y--comparing :: Ord a => (b -> a) -> b -> b -> Ordering-comparing p x y = p x `compare` p y--isInfixOf :: String -> String -> Bool-isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)  lowercase :: String -> String lowercase = map Char.toLower
cabal/Cabal/Distribution/System.hs view
@@ -13,7 +13,7 @@ -- probably know about the 'System.Info.os' however using that is very -- inconvenient because it is a string and different Haskell implementations -- do not agree on using the same strings for the same platforms! (In--- particular see the controversy over \"windows\" vs \"ming32\"). So to make it+-- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it -- more consistent and easy to use we have an 'OS' enumeration. -- module Distribution.System (@@ -28,18 +28,24 @@   -- * Platform is a pair of arch and OS   Platform(..),   buildPlatform,-  platformFromTriple+  platformFromTriple,++  -- * Internal+  knownOSs,+  knownArches   ) where  import qualified System.Info (os, arch)-import qualified Data.Char as Char (toLower, isAlphaNum)+import qualified Data.Char as Char (toLower, isAlphaNum, isAlpha) -import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Binary+import Distribution.Text+import qualified Distribution.Compat.ReadP as Parse++import Control.Monad (liftM2) import Data.Data (Data) import Data.Typeable (Typeable) import Data.Maybe (fromMaybe, listToMaybe)-import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse import GHC.Generics (Generic) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>))@@ -178,11 +184,21 @@  instance Text Platform where   disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os+  -- TODO: there are ambigious platforms like: `arch-word-os`+  -- which could be parsed as+  --   * Platform "arch-word" "os"+  --   * Platform "arch" "word-os"+  -- We could support that preferring variants 'OtherOS' or 'OtherArch'+  --+  -- For now we split into arch and os parts on the first dash.   parse = do-    arch <- parse+    arch <- parseDashlessArch     _ <- Parse.char '-'     os   <- parse     return (Platform arch os)+      where+        parseDashlessArch :: Parse.ReadP r Arch+        parseDashlessArch = fmap (classifyArch Strict) dashlessIdent  -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're@@ -193,9 +209,15 @@ -- Utils:  ident :: Parse.ReadP r String-ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')-  --TODO: probably should disallow starting with a number+ident = liftM2 (:) first rest+  where first = Parse.satisfy Char.isAlpha+        rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_' || c == '-') +dashlessIdent :: Parse.ReadP r String+dashlessIdent = liftM2 (:) first rest+  where first = Parse.satisfy Char.isAlpha+        rest = Parse.munch (\c -> Char.isAlphaNum c || c == '_')+ lowercase :: String -> String lowercase = map Char.toLower @@ -204,10 +226,10 @@   fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple)   where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_')         parseTriple = do-          arch <- fmap (classifyArch Strict) parseWord+          arch <- fmap (classifyArch Permissive) parseWord           _ <- Parse.char '-'           _ <- parseWord -- Skip vendor           _ <- Parse.char '-'-          os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like+          os <- fmap (classifyOS Permissive) ident -- OS may have hyphens, like                                                -- 'nto-qnx'           return $ Platform arch os
cabal/Cabal/Distribution/Text.hs view
@@ -13,6 +13,7 @@ -- module Distribution.Text (   Text(..),+  defaultStyle,   display,   simpleParse,   ) where@@ -27,13 +28,15 @@   disp  :: a -> Disp.Doc   parse :: Parse.ReadP r a +-- | The default rendering style used in Cabal for console output.+defaultStyle :: Disp.Style+defaultStyle = Disp.Style { Disp.mode           = Disp.PageMode+                          , Disp.lineLength     = 79+                          , Disp.ribbonsPerLine = 1.0+                          }+ display :: Text a => a -> String-display = Disp.renderStyle style . disp-  where style = Disp.Style {-          Disp.mode            = Disp.PageMode,-          Disp.lineLength      = 79,-          Disp.ribbonsPerLine  = 1.0-        }+display = Disp.renderStyle defaultStyle . disp  simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str@@ -51,19 +54,20 @@                        , (Parse.string "False" Parse.+++                           Parse.string "false") >> return False ] +instance Text Int where+  disp  = Disp.text . show+  parse = (fmap negate $ Parse.char '-' >> parseNat) Parse.+++ parseNat++-- | Parser for non-negative integers.+parseNat :: Parse.ReadP r Int+parseNat = read `fmap` Parse.munch1 Char.isDigit+ instance Text Version where   disp (Version branch _tags)     -- Death to version tags!!     = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))    parse = do-      branch <- Parse.sepBy1 digits (Parse.char '.')+      branch <- Parse.sepBy1 parseNat (Parse.char '.')                 -- allow but ignore tags:       _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum)       return (Version branch [])-    where-      digits = do-        first <- Parse.satisfy Char.isDigit-        if first == '0'-          then return 0-          else do rest <- Parse.munch Char.isDigit-                  return (read (first : rest))
cabal/Cabal/Distribution/Utils/NubList.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Distribution.Utils.NubList     ( NubList    -- opaque     , toNubList  -- smart construtor@@ -11,12 +10,9 @@     , overNubListR     ) where +import Distribution.Compat.Semigroup as Semi import Distribution.Compat.Binary-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif--import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight)+import Distribution.Simple.Utils  import qualified Text.Read as R @@ -54,8 +50,11 @@  instance Ord a => Monoid (NubList a) where     mempty = NubList []-    mappend (NubList xs) (NubList ys) = NubList $ xs `listUnion` ys+    mappend = (Semi.<>) +instance Ord a => Semigroup (NubList a) where+    (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys+ instance Show a => Show (NubList a) where     show (NubList list) = show list @@ -91,7 +90,10 @@  instance Ord a => Monoid (NubListR a) where   mempty = NubListR []-  mappend (NubListR xs) (NubListR ys) = NubListR $ xs `listUnionRight` ys+  mappend = (Semi.<>)++instance Ord a => Semigroup (NubListR a) where+  (NubListR xs) <> (NubListR ys) = NubListR $ xs `listUnionRight` ys  instance Show a => Show (NubListR a) where   show (NubListR list) = show list
cabal/Cabal/Distribution/Verbosity.hs view
@@ -24,9 +24,10 @@   showForCabal, showForGHC  ) where -import Distribution.Compat.Binary (Binary)-import Data.List (elemIndex)+import Distribution.Compat.Binary import Distribution.ReadE++import Data.List (elemIndex) import GHC.Generics  data Verbosity = Silent | Normal | Verbose | Deafening
cabal/Cabal/Distribution/Version.hs view
@@ -3,7 +3,28 @@ #if __GLASGOW_HASKELL__ < 707 {-# LANGUAGE StandaloneDeriving #-} #endif++-- Hack approach to support bootstrapping.+-- When MIN_VERSION_binary macro is available, use it. But it's not available+-- during bootstrapping (or anyone else building Setup.hs directly). If the+-- builder specifies -DMIN_VERSION_binary_0_8_0=1 or =0 then we respect that.+-- Otherwise we pick a default based on GHC version: assume binary <0.8 when+-- GHC < 8.0, and binary >=0.8 when GHC >= 8.0.+#ifdef MIN_VERSION_binary+#define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0)+#else+#ifndef MIN_VERSION_binary_0_8_0+#if __GLASGOW_HASKELL__ >= 800+#define MIN_VERSION_binary_0_8_0 1+#else+#define MIN_VERSION_binary_0_8_0 0+#endif+#endif+#endif++#if !MIN_VERSION_binary_0_8_0 {-# OPTIONS_GHC -fno-warn-orphans #-}+#endif  ----------------------------------------------------------------------------- -- |@@ -81,9 +102,10 @@ import Data.Version     ( Version(..) ) import GHC.Generics     ( Generic ) -import Distribution.Text ( Text(..) )+import Distribution.Text import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((+++))+import Distribution.Compat.ReadP hiding (get)+ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>), (<+>)) import qualified Data.Char as Char (isDigit)@@ -113,6 +135,7 @@ deriving instance Data Version #endif +#if !(MIN_VERSION_binary_0_8_0) -- Deriving this instance from Generic gives trouble on GHC 7.2 because the -- Generic instance has to be standalone-derived. So, we hand-roll our own. -- We can't use a generic Binary instance on later versions because we must@@ -123,14 +146,22 @@         tags <- get         return $ Version br tags     put (Version br tags) = put br >> put tags+#endif -{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}-{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DeprecateD AnyVersion+    "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED ThisVersion+    "Use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED LaterVersion+    "Use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED EarlierVersion+    "Use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED WildcardVersion+    "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED UnionVersionRanges+    "Use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-}+{-# DEPRECATED IntersectVersionRanges+    "Use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'"#-}  -- | The version range @-any@. That is, a version range containing all -- versions.@@ -216,7 +247,8 @@ -- invertVersionRange :: VersionRange -> VersionRange invertVersionRange =-    fromVersionIntervals . invertVersionIntervals . VersionIntervals . asVersionIntervals+    fromVersionIntervals . invertVersionIntervals+    . VersionIntervals . asVersionIntervals  -- | The version range @== v.*@. --@@ -286,9 +318,10 @@                    (orLaterVersion v)                    (earlierVersion (wildcardUpperBound v)) --- | An extended variant of 'foldVersionRange' that also provides a view of--- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented--- explicitly rather than in terms of the other basic syntax.+-- | An extended variant of 'foldVersionRange' that also provides a view of the+-- expression in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"==+-- v.*\"@ is presented explicitly rather than in terms of the other basic+-- syntax. -- foldVersionRange' :: a                         -- ^ @\"-any\"@ version                   -> (Version -> a)            -- ^ @\"== v\"@@@ -697,10 +730,12 @@       -- Empty interval set       [] -> VersionIntervals [(noLowerBound, NoUpperBound)]       -- Interval with no lower bound-      ((lb, ub) : more) | lb == noLowerBound -> VersionIntervals $ invertVersionIntervals' ub more+      ((lb, ub) : more) | lb == noLowerBound ->+        VersionIntervals $ invertVersionIntervals' ub more       -- Interval with a lower bound       ((lb, ub) : more) ->-          VersionIntervals $ (noLowerBound, invertLowerBound lb) : invertVersionIntervals' ub more+          VersionIntervals $ (noLowerBound, invertLowerBound lb)+          : invertVersionIntervals' ub more     where       -- Invert subsequent version intervals given the upper bound of       -- the intervals already inverted.@@ -743,8 +778,10 @@            (\v   -> (Disp.text ">=" <> disp v                   , 0))            (\v   -> (Disp.text "<=" <> disp v                   , 0))            (\v _ -> (Disp.text "==" <> dispWild v               , 0))-           (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))-           (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))+           (\(r1, p1) (r2, p2) ->+             (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))+           (\(r1, p1) (r2, p2) ->+             (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))            (\(r, _)   -> (Disp.parens r, 0))      where dispWild (Version b _) =@@ -812,14 +849,12 @@ -- -- @since 1.24.0.0 hasUpperBound :: VersionRange -> Bool-hasUpperBound AnyVersion = False-hasUpperBound (ThisVersion _) = True-hasUpperBound (LaterVersion _) = False-hasUpperBound (EarlierVersion _) = True-hasUpperBound (WildcardVersion _) = True-hasUpperBound (UnionVersionRanges x y) = hasUpperBound x && hasUpperBound y-hasUpperBound (IntersectVersionRanges x y) = hasUpperBound x || hasUpperBound y-hasUpperBound (VersionRangeParens x) = hasUpperBound x+hasUpperBound = foldVersionRange+                False+                (const True)+                (const False)+                (const True)+                (&&) (||)  -- | Does the version range have an explicit lower bound? --@@ -828,11 +863,9 @@ -- -- @since 1.24.0.0 hasLowerBound :: VersionRange -> Bool-hasLowerBound AnyVersion = False-hasLowerBound (ThisVersion _) = True-hasLowerBound (LaterVersion _) = True-hasLowerBound (EarlierVersion _) = False-hasLowerBound (WildcardVersion _) = True-hasLowerBound (UnionVersionRanges x y) = hasLowerBound x && hasLowerBound y-hasLowerBound (IntersectVersionRanges x y) = hasLowerBound x || hasLowerBound y-hasLowerBound (VersionRangeParens x) = hasLowerBound x+hasLowerBound = foldVersionRange+                False+                (const True)+                (const True)+                (const False)+                (&&) (||)
cabal/Cabal/Language/Haskell/Extension.hs view
@@ -22,12 +22,13 @@         deprecatedExtensions   ) where -import Distribution.Text (Text(..))+import Distribution.Text import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.Binary+ import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))-import Distribution.Compat.Binary (Binary) import Data.Data (Data) import Data.Typeable (Typeable) import GHC.Generics (Generic)@@ -713,6 +714,57 @@   --   -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#derive-any-class>   | DeriveAnyClass++  -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-lift>+  | DeriveLift++  -- | Enable support for 'static pointers' (and the @static@+  -- keyword) to refer to globally stable names, even across+  -- different programs.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/static-pointers.html>+  | StaticPointers++  -- | Switches data type declarations to be strict by default (as if+  -- they had a bang using @BangPatterns@), and allow opt-in field+  -- laziness using @~@.+  | StrictData++  -- | Switches all pattern bindings to be strict by default (as if+  -- they had a bang using @BangPatterns@), ordinary patterns are+  -- recovered using @~@. Implies @StrictData@.+  | Strict++  -- | Allows @do@-notation for types that are @'Applicative'@ as well+  -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use+  -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible.+  | ApplicativeDo++  -- | Allow records to use duplicated field labels for accessors.+  | DuplicateRecordFields++  -- | Enable explicit type applications with the syntax @id \@Int@.+  | TypeApplications++  -- | Dissolve the distinction between types and kinds, allowing the compiler+  -- to reason about kind equality and therefore enabling GADTs to be promoted+  -- to the type-level.+  | TypeInType++  -- | Allow recursive (and therefore undecideable) super-class relationships.+  | UndecidableSuperClasses++  -- | A temporary extension to help library authors check if their+  -- code will compile with the new planned desugaring of fail.+  | MonadFailDesugaring++  -- | A subset of @TemplateHaskell@ including only quasi-quoting.+  | TemplateHaskellQuotes++  -- | Allows use of the @#label@ syntax.+  | OverloadedLabels    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)
cabal/Cabal/Makefile view
@@ -1,5 +1,5 @@ -VERSION=1.23.0.0+VERSION=1.25.0.0  #KIND=devel KIND=rc@@ -14,7 +14,10 @@  # build the library itself -SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs+SOURCES=Distribution/*.hs Distribution/Simple/*.hs \+	Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs \+	Distribution/Simple/Build/*.hs Distribution/Compat/*.hs \+	Distribution/Simple/Program/*.hs CONFIG_STAMP=dist/setup-config BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a HADDOCK_STAMP=dist/doc/html/Cabal/index.html@@ -27,7 +30,8 @@  setup: $(SOURCES) Setup.hs 	-mkdir -p dist/setup-	$(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup+	$(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs \+		-o setup  $(CONFIG_STAMP): setup Cabal.cabal 	./setup configure --with-compiler=$(HC) --prefix=$(PREFIX)@@ -58,7 +62,9 @@ 	mkdir -p $(PANDOC_HTML_OUTDIR) 	for file in $^; do \ 		[ $${file} != doc/index.markdown ] && TOC=--table-of-contents || TOC=; \-		$(PANDOC) $(PANDOC_OPTIONS) $${TOC} --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; \+		$(PANDOC) $(PANDOC_OPTIONS) $${TOC} --from=markdown --to=html \+			--output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html \+			$${file}; \ 	done 	cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR)
cabal/Cabal/Setup.hs view
@@ -8,3 +8,6 @@ -- on any previous installation. This also means we can use any new features -- immediately because we never have to worry about building Cabal with an -- older version of itself.+--+-- NOTE 25/01/2015: Bootstrapping is disabled for now, see+-- https://github.com/haskell/cabal/issues/3003.
cabal/Cabal/changelog view
@@ -1,16 +1,49 @@ -*-change-log-*- -1.23.x.x (current development version)+1.25.x.x (current development version)+	* Dropped support for versions of GHC earlier than 6.12 (#3111).+	* Convenience/internal libraries are now supported (#269).+	  An internal library is declared using the stanza "library+	  'libname'".+	* Backwards incompatible change to preprocessor interface:+	  the function in 'PPSuffixHandler' now takes an additional+	  'ComponentLocalBuildInfo' specifying the build information+	  of the component being preprocessed.+	* Backwards incompatible change to 'cabal_macros.h' (#1893): we now+	  generate a macro file for each component which contains only+	  information about the direct dependencies of that component.+	  Consequently, 'dist/build/autogen/cabal_macros.h' contains+	  only the macros for the library, and is not generated if a+	  package has no library; to find the macros for an executable+	  named 'foobar', look in 'dist/build/foobar/autogen/cabal_macros.h'.++1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016+	* Support GHC 8. 	* Deal with extra C sources from preprocessors (#238). 	* Include cabal_macros.h when running c2hs (#2600). 	* Don't recompile C sources unless needed (#2601). 	* Read 'builddir' option from 'CABAL_BUILDDIR' environment variable-	* Add '--profiling-defail=$level' flag with a default for libraries+	* Add '--profiling-detail=$level' flag with a default for libraries 	  and executables of 'exported-functions' and 'toplevel-functions' 	  respetively (GHC's '-fprof-auto-{exported,top}' flags) (#193). 	* New 'custom-setup' stanza to specify setup deps. Setup is also built 	  with the cabal_macros.h style macros, for conditional compilation. 	* Support Haddock response files (#2746).+	* Fixed a bug in the Text instance for Platform (#2862).+	* New 'setup haddock' option: '--for-hackage' (#2852).+	* New --show-detail=direct; like streaming, but allows the test+	  program to detect that is connected to a terminal, and works+	  reliable with a non-threaded runtime (#2911, and serves as a+	  work-around for #2398)+	* Library support for multi-instance package DBs (#2948).+	* Improved the './Setup configure' solver (#3082, #3076).+	* The '--allow-newer' option can be now used with './Setup+	configure' (#3163).+	* Added a way to specify extra locations to find OS X frameworks+	in ('extra-framework-dirs'). Can be used both in .cabal files and+	as an argument to './Setup configure' (#3158).+	* Macros 'VERSION_$pkgname' and 'MIN_VERSION_$pkgname' are now+	also generated for the current package. (#3235).  1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 	* Support GHC 7.10.@@ -43,7 +76,7 @@ 	* Make 'cabal test'/'cabal bench' build only what's needed for 	running tests/benchmarks (#1821). 	* Build shared libraries by default when linking executables dynamically.-	* Build profiled libraries by default when profiling executable.s+	* Build profiled libraries by default when profiling executables.  1.20.0.1 Johan Tibell <johan.tibell@gmail.com> May 2014 	* Fix streaming test output.
cabal/Cabal/doc/developing-packages.markdown view
@@ -676,10 +676,11 @@ The syntax of the value depends on the field.  Field types include:  _token_, _filename_, _directory_-:   Either a sequence of one or more non-space non-comma characters, or-    a quoted string in Haskell 98 lexical syntax. Unless otherwise-    stated, relative filenames and directories are interpreted from the-    package root directory.+:   Either a sequence of one or more non-space non-comma characters, or a quoted+    string in Haskell 98 lexical syntax. The latter can be used for escaping+    whitespace, for example: `ghc-options: -Wall "-with-rtsopts=-T -I1"`.+    Unless otherwise stated, relative filenames and directories are interpreted+    from the package root directory.  _freeform_, _URL_, _address_ :   An arbitrary, uninterpreted string.@@ -965,6 +966,43 @@ The library section may also contain build information fields (see the section on [build information](#build-information)). +Cabal 1.23 and later support "internal libraries", which are extra named+libraries (as opposed to the usual unnamed library section).  For+example, suppose that your test suite needs access to some internal+modules in your library, which you do not otherwise want to export.  You+could put these modules in an internal library, which the main library+and the test suite `build-depends` upon.  Then your Cabal file might+look something like this:++~~~~~~~~~~~~~~~~+name:           foo+version:        1.0+license:        BSD3+cabal-version:  >= 1.23+build-type:     Simple++library foo-internal+    exposed-modules: Foo.Internal+    build-depends: base++library+    exposed-modules: Foo.Public+    build-depends: foo-internal, base++test-suite test-foo+    type:       exitcode-stdio-1.0+    main-is:    test-foo.hs+    build-depends: foo-internal, base+~~~~~~~~~~~~~~~~++Internal libraries are also useful for packages that define multiple+executables, but do not define a publically accessible library.+Internal libraries are only visible internally in the package (so they+can only be added to the `build-depends` of same-package libraries,+executables, test suites, etc.)  Internal libraries locally shadow any+packages which have the same name (so don't name an internal library+with the same name as an external dependency.)+ #### Opening an interpreter session ####  While developing a package, it is often useful to make its code available inside@@ -1002,6 +1040,32 @@ `cabal.config` file.  All environments which share this file will use the dependency versions specified in it. +#### Generating dependency version bounds ####++Cabal also has the ability to suggest dependency version bounds that conform to+[Package Versioning Policy][PVP], which is a recommended versioning system for+publicly released Cabal packages. This is done by running the `gen-bounds`+command:++~~~~~~~~~~~~~~~~+cabal gen-bounds+~~~~~~~~~~~~~~~~++For example, given the following dependencies specified in `build-depends`:++~~~~~~~~~~~~~~~~+foo == 0.5.2+bar == 1.1+~~~~~~~~~~~~~~~~++`gen-bounds` will suggest changing them to the following:++~~~~~~~~~~~~~~~~+foo >= 0.5.2 && < 0.6+bar >= 1.1 && < 1.2+~~~~~~~~~~~~~~~~++ ### Executables ###  Executable sections (if present) describe executable programs contained@@ -1255,12 +1319,12 @@  ### Build information ### -The following fields may be optionally present in a library or-executable section, and give information for the building of the+The following fields may be optionally present in a library, executable, test+suite or benchmark section, and give information for the building of the corresponding library or executable.  See also the sections on [system-dependent parameters](#system-dependent-parameters) and-[configurations](#configurations) for a way to supply system-dependent-values for these fields.+[configurations](#configurations) for a way to supply system-dependent values+for these fields.  `build-depends:` _package list_ :   A list of packages needed to build this one. Each package can be@@ -1290,29 +1354,16 @@      It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. -    With Cabal 1.20 and GHC 7.10, `build-depends` also supports module-    thinning and renaming, which allows you to selectively decide what-    modules become visible from a package dependency.  For example:--    ~~~~~~~~~~~~~~~~-    build-depends: containers (Data.Set, Data.IntMap as Map)-    ~~~~~~~~~~~~~~~~--    This results in only the modules `Data.Set` and `Map` being visible to-    the user from containers, hiding all other modules.  To add additional-    names for modules without hiding the others, you can use the `with`-    keyword:--    ~~~~~~~~~~~~~~~~-    build-depends: containers with (Data.IntMap as Map)-    ~~~~~~~~~~~~~~~~-     Note: Prior to Cabal 1.8, build-depends specified in each section     were global to all sections. This was unintentional, but some packages     were written to depend on it, so if you need your build-depends to     be local to each section, you must specify at least     `Cabal-Version: >= 1.8` in your `.cabal` file. +    Note: Cabal 1.20 experimentally supported module thinning and+    renaming in `build-depends`; however, this support has since been+    removed and should not be used.+ `other-modules:` _identifier list_ :   A list of modules used by the component but not exposed to users.     For a library component, these would be hidden modules of the@@ -1362,8 +1413,10 @@  `build-tools:` _program list_ :   A list of programs, possibly annotated with versions, needed to-    build this package, e.g. `c2hs >= 0.15, cpphs`.If no version+    build this package, e.g. `c2hs >= 0.15, cpphs`.  If no version     constraint is specified, any version is assumed to be acceptable.+    `build-tools` can refer to locally defined executables, in which+    case Cabal will make sure that executable is built first.  `buildable:` _boolean_ (default: `True`) :   Is the component buildable? Like some of the other fields below,@@ -1378,12 +1431,15 @@     Options required only by one module may be specified by placing an     `OPTIONS_GHC` pragma in the source file affected. +    As with many other fields, whitespace can be escaped by using Haskell string+    syntax. Example: `ghc-options: -Wcompat "-with-rtsopts=-T -I1" -Wall`.+ `ghc-prof-options:` _token list_ :   Additional options for GHC when the package is built with profiling     enabled.      Note that as of Cabal-1.24, the default profiling detail level defaults to-    `exported-functions` for libraries and `toplevel-funcitons` for+    `exported-functions` for libraries and `toplevel-functions` for     executables. For GHC these correspond to the flags `-fprof-auto-exported`     and `-fprof-auto-top`. Prior to Cabal-1.24 the level defaulted to `none`.     These levels can be adjusted by the person building the package with the@@ -1399,6 +1455,9 @@  `ghc-shared-options:` _token list_ :   Additional options for GHC when the package is built as shared library.+    The options specified via this field are combined with the ones specified+    via `ghc-options`, and are passed to GHC during both the compile and+    link phases.  `includes:` _filename list_ :   A list of header files to be included in any compilations via C.@@ -1460,7 +1519,7 @@     parameters](#system-dependent-parameters)>.  `pkgconfig-depends:` _package list_-:   A list of [pkg-config][] packages, needed to build this package.+:   A list of [pkg-config] packages, needed to build this package.     They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo     >= 1.0`. If no version constraint is specified, any version is     assumed to be acceptable. Cabal uses `pkg-config` to find if the@@ -1477,6 +1536,10 @@     developer documentation for more details on frameworks.  This entry     is ignored on all other platforms. +`extra-frameworks-dirs:` _directory list_+:   On Darwin/MacOS X, a list of directories to search for frameworks.+    This entry is ignored on all other platforms.+ ### Configurations ###  Library and executable sections may include conditional@@ -2189,3 +2252,4 @@ [Hackage]:    http://hackage.haskell.org/ [pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/ [REPL]:       http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop+[PVP]:        https://wiki.haskell.org/Package_versioning_policy
cabal/Cabal/doc/index.markdown view
@@ -1,4 +1,5 @@ % Cabal User Guide+**Version: 1.25.0.0**  Cabal is the standard package system for [Haskell] software. It helps people to configure, build and install Haskell software and to
cabal/Cabal/doc/installing-packages.markdown view
@@ -1,5 +1,140 @@ % Cabal User Guide +# Configuration #++## Overview ##++The global configuration file for `cabal-install` is `~/.cabal/config`. If you+do not have this file, `cabal` will create it for you on the first call to+`cabal update`. Alternatively, you can explicitly ask `cabal` to create it for+you using++> `cabal user-config update`++Most of the options in this configuration file are also available as command+line arguments, and the corresponding documentation can be used to lookup their+meaning. The created configuration file only specifies values for a handful of+options. Most options are left at their default value, which it documents;+for instance,++~~~~~~~~~~~~~~~~+-- executable-stripping: True+~~~~~~~~~~~~~~~~++means that the configuration file currently does not specify a value for the+`executable-stripping` option (the line is commented out), and that the default+is `True`; if you wanted to disable stripping of executables by default, you+would change this line to++~~~~~~~~~~~~~~~~+executable-stripping: False+~~~~~~~~~~~~~~~~++You can also use `cabal user-config update` to migrate configuration files+created by older versions of `cabal`.++## Repository specification ##++An important part of the configuration if the specification of the repository.+When `cabal` creates a default config file, it configures the repository to+be the central Hackage server:++~~~~~~~~~~~~~~~~+repository hackage.haskell.org+  url: http://hackage.haskell.org/+~~~~~~~~~~~~~~~~++The name of the repository is given on the first line, and can be anything;+packages downloaded from this repository will be cached under+`~/.cabal/packages/hackage.haskell.org` (or whatever name you specify; you can+change the prefix by changing the value of `remote-repo-cache`). If you want,+you can configure multiple repositories, and `cabal` will combine them and be+able to download packages from any of them.++### Using secure repositories ###++For repositories that support the TUF security infrastructure (this includes+Hackage), you can enable secure access to the repository by specifying:++~~~~~~~~~~~~~~~~+repository hackage.haskell.org+  url: http://hackage.haskell.org/+  secure: True+  root-keys: <root-key-IDs>+  key-threshold: <key-threshold>+~~~~~~~~~~~~~~~~++The `<root-key-IDs>` and `<key-threshold>` values are used for bootstrapping. As+part of the TUF infrastructure the repository will contain a file `root.json`+(for instance,+[http://hackage.haskell.org/root.json](http://hackage.haskell.org/root.json))+which the client needs to do verification. However, how  can `cabal` verify the+`root.json` file _itself_? This is known as bootstrapping: if you specify a list+of root key IDs and a corresponding  threshold, `cabal` will verify that the+downloaded `root.json` file has been  signed with at least `<key-threshold>`+keys from your set of `<root-key-IDs>`.++You can, but are not recommended to, omit these two fields. In that case `cabal`+will download the `root.json` field and use it without verification. Although+this bootstrapping step is then unsafe, all subsequent access is secure+(provided that the downloaded `root.json` was not tempered with). Of course,+adding `root-keys` and `key-threshold` to your repository specification only+shifts the problem, because now you somehow need to make sure that the key IDs+you received were the right ones. How that is done is however outside the scope+of `cabal` proper.++More information about the security infrastructure can be found at+[https://github.com/well-typed/hackage-security](https://github.com/well-typed/hackage-security).++### Legacy repositories ###++Currently `cabal` supports two kinds of &ldquo;legacy&rdquo; repositories. The+first is specified using++~~~~~~~~~~~~~~~~+remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive+~~~~~~~~~~~~~~~~++This is just syntactic sugar for++~~~~~~~~~~~~~~~~+repository hackage.haskell.org+  url: hackage.haskell.org:http://hackage.haskell.org/packages/archive+~~~~~~~~~~~~~~~~++although, in (and only in) the specific case of Hackage, the URL+`http://hackage.haskell.org/packages/archive` will be silently translated to+`http://hackage.haskell.org/`.++The second kind of legacy repositories are so-called &ldquo;local&rdquo;+repositories:++~~~~~~~~~~~~~~~~+local-repo: my-local-repo:/path/to/local/repo+~~~~~~~~~~~~~~~~++This can be used to access repositories on the local file system. However, the+layout of these local repositories is different from the layout of remote+repositories, and usage of these local repositories is deprecated.++### Secure local repositories ###++If you want to use repositories on your local file system, it is recommended+instead to use a _secure_ local repository:++~~~~~~~~~~~~~~~~+repository my-local-repo+  url: file:/path/to/local/repo+  secure: True+  root-keys: <root-key-IDs>+  key-threshold: <key-threshold>+~~~~~~~~~~~~~~~~++The layout of these secure local repos matches the layout of remote repositories+exactly; the+[hackage-repo-tool](http://hackage.haskell.org/package/hackage-repo-tool) can be+used to create and manage such repositories.+ # Building and installing packages #  After you've unpacked a Cabal package, you can build it by moving into@@ -610,6 +745,14 @@     be a file or directory. Not all implementations support arbitrary     package databases. +`--default-user-config=` _file_+:   Allows a "default" `cabal.config` freeze file to be passed in+    manually. This file will only be used if one does not exist in the+    project directory already. Typically, this can be set from the global+    cabal `config` file so as to provide a default set of partial+    constraints to be used by projects, providing a way for users to peg+    themselves to stable package collections.+ `--enable-optimization`[=_n_] or `-O`[_n_] :   (default) Build with optimization flags (if available). This is     appropriate for production use, taking more time to build faster@@ -789,6 +932,10 @@ :   An extra directory to search for system libraries files. You can use     this flag multiple times to get a list of directories. +`--extra-framework-dirs`[=_dir_]+:   An extra directory to search for frameworks (OS X only). You can use this+    flag multiple times to get a list of directories.+     You might need to use this flag if you have standard system     libraries in a non-standard location that is not mentioned in the     package's `.cabal` file. Using this option has the same affect as@@ -835,8 +982,26 @@     $ cabal install --allow-newer=bar --constraint="bar==2.1" foo     ~~~~~~~~~~~~~~~~ -    It's also possible to enable `--allow-newer` permanently by setting-    `allow-newer: True` in the `~/.cabal/config` file.+    It's also possible to limit the scope of `--allow-newer` to single+    packages with the `--allow-newer=scope:dep` syntax. This means that the+    dependency on `dep` will be relaxed only for the package `scope`.++    Example:++    ~~~~~~~~~~~~~~~~+    # Relax upper bound in foo's dependency on base; also relax upper bound in+    # every package's dependency on lens.+    $ cabal install --allow-newer=foo:base,lens++    # Relax upper bounds in foo's dependency on base and bar's dependency+    # on time; also relax the upper bound in the dependency on lens specified by+    # any package.+    $ cabal install --allow-newer=foo:base,lens --allow-newer=bar:time+    ~~~~~~~~~~~~~~~~++    Finally, one can enable `--allow-newer` permanently by setting `allow-newer:+    True` in the `~/.cabal/config` file. Enabling 'allow-newer' selectively is+    also supported in the config file (`allow-newer: foo, bar, baz:base`).  `--constraint=`_constraint_ :   Restrict solutions involving a package to a given version range.
cabal/Cabal/misc/gen-extra-source-files.sh view
@@ -1,5 +1,22 @@-#! /bin/sh+#!/bin/sh +if [ "$#" -ne 1 ]; then+    echo "Error: too few arguments!"+    echo "Usage: $0 FILE"+    exit 1+fi++set -ex+ find tests -type f \( -name '*.hs' -or -name '*.lhs' -or -name '*.c' -or -name '*.sh' \-    -or -name '*.cabal' -or -name '*.hsc' \) -and -not -regex ".*/dist/.*" \-    | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|CreatePipe/ { next } { print }'+    -or -name '*.cabal' -or -name '*.hsc' -or -name '*.err' -or -name '*.out' -or -name "ghc*" \) -and -not -regex ".*/dist.*/.*" \+    | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|IntegrationTests.hs|CreatePipe|^tests\/Test/ { next } { print }' \+    | LC_ALL=C sort \+    | sed -e 's/^/  /' \+    > source-file-list++lead='^  -- BEGIN gen-extra-source-files'+tail='^  -- END gen-extra-source-files'+# cribbed off of http://superuser.com/questions/440013/how-to-replace-part-of-a-text-file-between-markers-with-another-text-file+sed -i.bak -e "/$lead/,/$tail/{ /$lead/{p; r source-file-list+              }; /$tail/p; d }" $1
+ cabal/Cabal/misc/travis-diff-files.sh view
@@ -0,0 +1,3 @@+#!/bin/sh+git status > /dev/null # See https://github.com/haskell/cabal/pull/3088#commitcomment-15818452+git diff-files -p --exit-code
cabal/HACKING.md view
@@ -34,7 +34,7 @@ _The steps below will make use of sandboxes for building. The process might be somewhat different when you do not want to use sandboxes._ -Building Cabal from from source requires the following:+Building Cabal from source requires the following:  * Glorious/Glasgow Haskell Compiler (ghc). * An existing (relatively recent) `cabal` binary (e.g. obtained as part of the@@ -70,7 +70,7 @@     we cannot use `cabal` for the next steps;     we need to use Setup instead.     So, compile Setup.hs:-    +     ~~~~     ghc --make -threaded Setup.hs     ~~~~@@ -89,7 +89,7 @@     ~~~~     ~/MyHaskellCode/cabal/Cabal/.cabal-sandbox/$SOMESTUFF-packages.conf.d     ~~~~-    +     (or, as a relative path with my setup:)      ~~~~@@ -128,6 +128,18 @@ (In addition, the absolute sandbox path will be slightly different because we have to use the `cabal-install` sandbox, not the Cabal one. If you use the relative path, you are set.)++Coding Conventions+------------------++Use spaces, not tabs. Use lines no longer than 80 characters. If you modify a+file, please follow the style conventions used in that file. When you add a new+top-level definition, please also add a Haddock comment. Use explicit import+lists for third-party and standard library imports. Use of GHC extensions is+allowed (except Template Haskell), provided that the dependencies policy is+respected. In general, try to adhere to [this style guide][guide].++[guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md  Dependencies policy -------------------
cabal/Paths_Cabal.hs view
@@ -5,4 +5,4 @@ import Data.Version (Version(..))  version :: Version-version = Version {versionBranch = [1,23,0,0], versionTags = []}+version = Version [1,25,0,0] []
cabal/Paths_cabal_install.hs view
@@ -5,4 +5,4 @@ import Data.Version (Version(..))  version :: Version-version = Version {versionBranch = [1,23,0,0], versionTags = []}+version = Version [1,25,0,0] []
cabal/README.md view
@@ -1,4 +1,4 @@-# Cabal [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal)+# Cabal [![Hackage version](https://img.shields.io/hackage/v/Cabal.svg?label=Hackage)](https://hackage.haskell.org/package/Cabal) [![Build Status](https://secure.travis-ci.org/haskell/cabal.svg?branch=master)](http://travis-ci.org/haskell/cabal) [![Windows build status](https://ci.appveyor.com/api/projects/status/yotutrf4i4wn5d9y/branch/master?svg=true)](https://ci.appveyor.com/project/23Skidoo/cabal)  This Cabal Git repository contains the following packages:
+ cabal/appveyor.yml view
@@ -0,0 +1,28 @@+install:+  - choco install ghc -version 7.10.3 > NUL+  - SET PATH=%PATH%;C:\tools\ghc\ghc-7.10.3\bin+  - curl -o cabal.zip --silent https://www.haskell.org/cabal/release/cabal-install-1.24.0.0-rc1/cabal-install-1.24.0.0-rc1-x86_64-unknown-mingw32.zip+  - 7z x -bd cabal.zip+  - cabal --version+  - cabal update++build_script:+  - cd Cabal+  - ghc --make -threaded -i -i. Setup.hs -Wall -Werror++  # 'echo "" |' works around an AppVeyor issue:+  # https://github.com/commercialhaskell/stack/issues/1097#issuecomment-145747849+  - echo "" | ..\cabal install --only-dependencies --enable-tests++  - Setup configure --user --ghc-option=-Werror --enable-tests+  - Setup build+  - Setup test --show-details=streaming --test-option=--hide-successes+  - Setup install+  - cd ..\cabal-install+  - ghc --make -threaded -i -i. Setup.hs -Wall -Werror+  - echo "" | ..\cabal install happy+  - echo "" | ..\cabal install --only-dependencies --enable-tests+  - ..\cabal configure --user --ghc-option=-Werror --enable-tests+  - ..\cabal build+  - ..\cabal test unit-tests --show-details=streaming --test-option=--pattern=!FileMonitor --test-option=--hide-successes+  - ..\cabal test integration-tests --show-details=streaming --test-option=--pattern=!exec --test-option=--hide-successes
cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view
@@ -191,7 +191,6 @@   ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror   ParseOk   _ report -> Right report ---FIXME: this does not allow for optional or repeated fields parseFields :: String -> ParseResult BuildReport parseFields input = do   fields <- mapM extractField =<< readFields input
cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view
@@ -79,7 +79,9 @@                -> [(BuildReport, Repo, RemoteRepo)]     onlyRemote rs =       [ (report, repo, remoteRepo)-      | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]+      | (report, Just repo) <- rs+      , Just remoteRepo     <- [maybeRepoRemote repo]+      ]  storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]            -> Platform -> IO ()@@ -101,7 +103,7 @@         fromPathTemplate (substPathTemplate env template)       where env = initialPathTemplateEnv                     (BuildReport.package  report)-                    -- ToDo: In principle, we can support $pkgkey, but only+                    -- TODO: In principle, we can support $pkgkey, but only                     -- if the configure step succeeds.  So add a Maybe field                     -- to the build report, and either use that or make up                     -- a fake identifier if it's not available.@@ -130,7 +132,7 @@                 -> InstallPlan.PlanPackage                 -> Maybe (BuildReport, Maybe Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of-  InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ _) deps)+  InstallPlan.Installed (ReadyPackage (ConfiguredPackage srcPkg flags _ deps))                          _ result     -> Just $ ( BuildReport.new os arch comp                                 (packageId srcPkg) flags
cabal/cabal-install/Distribution/Client/BuildReports/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.BuildReports.Types@@ -24,9 +25,14 @@  import Data.Char as Char          ( isAlpha, toLower )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary) + data ReportLevel = NoReports | AnonymousReports | DetailedReports-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Enum, Show, Generic)++instance Binary ReportLevel  instance Text.Text ReportLevel where   disp NoReports        = Disp.text "none"
cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs view
@@ -27,22 +27,24 @@ import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils (die) import Distribution.Client.HttpUtils+import Distribution.Client.Setup+         ( RepoContext(..) )  type BuildReportId = URI type BuildLog = String -uploadReports :: Verbosity -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()-uploadReports verbosity auth uri reports = do+uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()+uploadReports verbosity repoCtxt auth uri reports = do   forM_ reports $ \(report, mbBuildLog) -> do-     buildId <- postBuildReport verbosity auth uri report+     buildId <- postBuildReport verbosity repoCtxt auth uri report      case mbBuildLog of-       Just buildLog -> putBuildLog verbosity auth buildId buildLog+       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog        Nothing       -> return () -postBuildReport :: Verbosity -> (String, String) -> URI -> BuildReport -> IO BuildReportId-postBuildReport verbosity auth uri buildReport = do+postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId+postBuildReport verbosity repoCtxt auth uri buildReport = do   let fullURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" }-  transport <- configureTransport verbosity Nothing+  transport <- repoContextGetTransport repoCtxt   res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth)   case res of     (303, redir) -> return $ undefined redir --TODO parse redir@@ -78,12 +80,12 @@  -- TODO force this to be a PUT? -putBuildLog :: Verbosity -> (String, String)+putBuildLog :: Verbosity -> RepoContext -> (String, String)             -> BuildReportId -> BuildLog             -> IO ()-putBuildLog verbosity auth reportId buildLog = do+putBuildLog verbosity repoCtxt auth reportId buildLog = do   let fullURI = reportId {uriPath = uriPath reportId </> "log"}-  transport <- configureTransport verbosity Nothing+  transport <- repoContextGetTransport repoCtxt   res <- postHttp transport verbosity fullURI buildLog (Just auth)   case res of     (200, _) -> return ()
cabal/cabal-install/Distribution/Client/Compat/Time.hs view
@@ -1,74 +1,69 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, GeneralizedNewtypeDeriving #-} module Distribution.Client.Compat.Time-       (EpochTime, getModTime, getFileAge, getCurTime)+       ( ModTime(..) -- Needed for testing+       , getModTime, getFileAge, getCurTime+       , posixSecondsToModTime )        where -import Data.Int (Int64)-import System.Directory (getModificationTime)+import Control.Arrow    ( first )+import Data.Int         ( Int64 )+import Data.Word        ( Word64 )+import System.Directory ( getModificationTime ) +import Distribution.Compat.Binary ( Binary )++import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) #if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength)-import Data.Time (getCurrentTime, diffUTCTime)+import Data.Time.Clock.POSIX ( posixDayLength )+import Data.Time             ( diffUTCTime, getCurrentTime ) #else-import System.Time (ClockTime(..), getClockTime-                   ,diffClockTimes, normalizeTimeDiff, tdDay, tdHour)+import System.Time ( getClockTime, diffClockTimes+                   , normalizeTimeDiff, tdDay, tdHour ) #endif  #if defined mingw32_HOST_OS +import Data.Bits          ((.|.), unsafeShiftL) #if MIN_VERSION_base(4,7,0)-import Data.Bits          ((.|.), finiteBitSize, unsafeShiftL)-#else-import Data.Bits          ((.|.), bitSize, unsafeShiftL)-#endif-import Data.Int           (Int32)-import Data.Word          (Word64)-import Foreign            (allocaBytes, peekByteOff)-import System.IO.Error    (mkIOError, doesNotExistErrorType)-import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString)--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall+import Data.Bits          (finiteBitSize) #else-#define CALLCONV stdcall+import Data.Bits          (bitSize) #endif -foreign import CALLCONV "windows.h GetFileAttributesExW"-  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL--getFileAttributesEx :: String -> LPVOID -> IO BOOL-getFileAttributesEx path lpFileInformation =-  withTString path $ \c_path ->-      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation--getFileExInfoStandard :: Int32-getFileExInfoStandard = 0--size_WIN32_FILE_ATTRIBUTE_DATA :: Int-size_WIN32_FILE_ATTRIBUTE_DATA = 36+import Data.Int           ( Int32 )+import Foreign            ( allocaBytes, peekByteOff )+import System.IO.Error    ( mkIOError, doesNotExistErrorType )+import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20+#else -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int-index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24+import System.Posix.Files ( FileStatus, getFileStatus ) +#if MIN_VERSION_unix(2,6,0)+import System.Posix.Files ( modificationTimeHiRes ) #else--import Foreign.C.Types    (CTime(..))-import System.Posix.Files (getFileStatus, modificationTime)+import System.Posix.Files ( modificationTime )+#endif  #endif --- | The number of seconds since the UNIX epoch.-type EpochTime = Int64+-- | An opaque type representing a file's modification time, represented+-- internally as a 64-bit unsigned integer in the Windows UTC format.+newtype ModTime = ModTime Word64+                deriving (Binary, Bounded, Eq, Ord) --- | Return modification time of given file. Works around the low clock+instance Show ModTime where+  show (ModTime x) = show x++instance Read ModTime where+  readsPrec p str = map (first ModTime) (readsPrec p str)++-- | Return modification time of the given file. Works around the low clock -- resolution problem that 'getModificationTime' has on GHC < 7.8. ----- This is a modified version of the code originally written for OpenShake by--- Neil Mitchell. See module Development.Shake.FileTime.-getModTime :: FilePath -> IO EpochTime+-- This is a modified version of the code originally written for Shake by Neil+-- Mitchell. See module Development.Shake.FileInfo.+getModTime :: FilePath -> IO ModTime  #if defined mingw32_HOST_OS @@ -86,39 +81,74 @@                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime       dwHigh <- peekByteOff info                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime-      return $! windowsTimeToPOSIXSeconds dwLow dwHigh-        where-          windowsTimeToPOSIXSeconds :: DWORD -> DWORD -> EpochTime-          windowsTimeToPOSIXSeconds dwLow dwHigh =-            let wINDOWS_TICK      = 10000000-                sEC_TO_UNIX_EPOCH = 11644473600 #if MIN_VERSION_base(4,7,0)-                qwTime = (fromIntegral dwHigh `unsafeShiftL` finiteBitSize dwHigh)-                         .|. (fromIntegral dwLow)+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD)) #else-                qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)-                         .|. (fromIntegral dwLow)+      let qwTime =+            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)+            .|. (fromIntegral (dwLow :: DWORD)) #endif-                res    = ((qwTime :: Word64) `div` wINDOWS_TICK)-                         - sEC_TO_UNIX_EPOCH-            -- TODO: What if the result is not representable as POSIX seconds?-            -- Probably fine to return garbage.-            in fromIntegral res+      return $! ModTime (qwTime :: Word64)++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall #else+#define CALLCONV stdcall+#endif +foreign import CALLCONV "windows.h GetFileAttributesExW"+  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL++getFileAttributesEx :: String -> LPVOID -> IO BOOL+getFileAttributesEx path lpFileInformation =+  withTString path $ \c_path ->+      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation++getFileExInfoStandard :: Int32+getFileExInfoStandard = 0++size_WIN32_FILE_ATTRIBUTE_DATA :: Int+size_WIN32_FILE_ATTRIBUTE_DATA = 36++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24++#else+ -- Directly against the unix library. getModTime path = do-    -- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in-    -- base < 4.5.-    t <- fmap modificationTime $ getFileStatus path-#if MIN_VERSION_base(4,5,0)-    let CTime i = t-    return (fromIntegral i)+    st <- getFileStatus path+    return $! (extractFileTime st)++extractFileTime :: FileStatus -> ModTime+#if MIN_VERSION_unix(2,6,0)+extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) #else-    return (read . show $ t)+extractFileTime x = posixSecondsToModTime $ fromIntegral $ fromEnum $+                    modificationTime x #endif+ #endif +windowsTick, secToUnixEpoch :: Word64+windowsTick    = 10000000+secToUnixEpoch = 11644473600++-- | Convert POSIX seconds to ModTime.+posixSecondsToModTime :: Int64 -> ModTime+posixSecondsToModTime s =+  ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick++-- | Convert 'POSIXTime' to 'ModTime'.+posixTimeToModTime :: POSIXTime -> ModTime+posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision+                       + (secToUnixEpoch * windowsTick)+ -- | Return age of given file in days. getFileAge :: FilePath -> IO Double getFileAge file = do@@ -132,11 +162,6 @@   return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0 #endif -getCurTime :: IO EpochTime-getCurTime =  do-#if MIN_VERSION_directory(1,2,0)-  (truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime-#else-  (TOD s _) <- getClockTime-  return $! fromIntegral s-#endif+-- | Return the current time as 'ModTime'.+getCurTime :: IO ModTime+getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
cabal/cabal-install/Distribution/Client/ComponentDeps.hs view
@@ -10,6 +10,7 @@ -- > import qualified Distribution.Client.ComponentDeps as CD {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} module Distribution.Client.ComponentDeps (     -- * Fine-grained package dependencies     Component(..)@@ -20,6 +21,7 @@   , fromList   , singleton   , insert+  , filterDeps   , fromLibraryDeps   , fromSetupDeps   , fromInstalled@@ -34,6 +36,9 @@  import Data.Map (Map) import qualified Data.Map as Map+import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Semigroup (Semigroup((<>)))+import GHC.Generics import Data.Foldable (fold)  #if !MIN_VERSION_base(4,8,0)@@ -46,34 +51,44 @@   Types -------------------------------------------------------------------------------} --- | Component of a package+-- | Component of a package. data Component =-    ComponentLib+    ComponentLib   String   | ComponentExe   String   | ComponentTest  String   | ComponentBench String   | ComponentSetup-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) --- | Dependency for a single component+instance Binary Component++-- | Dependency for a single component. type ComponentDep a = (Component, a) --- | Fine-grained dependencies for a package+-- | Fine-grained dependencies for a package.+--+-- Typically used as @ComponentDeps [Dependency]@, to represent the list of+-- dependencies for each named component within a package.+-- newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }-  deriving (Show, Functor, Eq, Ord)+  deriving (Show, Functor, Eq, Ord, Generic) -instance Monoid a => Monoid (ComponentDeps a) where-  mempty =-    ComponentDeps Map.empty-  (ComponentDeps d) `mappend` (ComponentDeps d') =-    ComponentDeps (Map.unionWith mappend d d')+instance Semigroup a => Monoid (ComponentDeps a) where+  mempty = ComponentDeps Map.empty+  mappend = (<>) +instance Semigroup a => Semigroup (ComponentDeps a) where+  ComponentDeps d <> ComponentDeps d' =+      ComponentDeps (Map.unionWith (<>) d d')+ instance Foldable ComponentDeps where   foldMap f = foldMap f . unComponentDeps  instance Traversable ComponentDeps where   traverse f = fmap ComponentDeps . traverse f . unComponentDeps +instance Binary a => Binary (ComponentDeps a)+ {-------------------------------------------------------------------------------   Construction -------------------------------------------------------------------------------}@@ -93,18 +108,22 @@     aux Nothing   = Just a     aux (Just a') = Just $ a `mappend` a' +-- | Keep only selected components (and their associated deps info).+filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a+filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps+ -- | ComponentDeps containing library dependencies only-fromLibraryDeps :: a -> ComponentDeps a-fromLibraryDeps = singleton ComponentLib+fromLibraryDeps :: String -> a -> ComponentDeps a+fromLibraryDeps n = singleton (ComponentLib n) --- | ComponentDeps containing setup dependencies only+-- | ComponentDeps containing setup dependencies only. fromSetupDeps :: a -> ComponentDeps a fromSetupDeps = singleton ComponentSetup --- | ComponentDeps for installed packages+-- | ComponentDeps for installed packages. ----- We assume that installed packages only record their library dependencies-fromInstalled :: a -> ComponentDeps a+-- We assume that installed packages only record their library dependencies.+fromInstalled :: String -> a -> ComponentDeps a fromInstalled = fromLibraryDeps  {-------------------------------------------------------------------------------@@ -114,7 +133,7 @@ toList :: ComponentDeps a -> [ComponentDep a] toList = Map.toList . unComponentDeps --- | All dependencies of a package+-- | All dependencies of a package. -- -- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more -- obvious than a use of 'fold', and moreover this avoids introducing lots of@@ -122,21 +141,22 @@ flatDeps :: Monoid a => ComponentDeps a -> a flatDeps = fold --- | All dependencies except the setup dependencies+-- | All dependencies except the setup dependencies. ----- Prior to the introduction of setup dependencies (TODO: Version? 1.23) this--- would have been _all_ dependencies+-- Prior to the introduction of setup dependencies in version 1.24 this+-- would have been _all_ dependencies. nonSetupDeps :: Monoid a => ComponentDeps a -> a nonSetupDeps = select (/= ComponentSetup) --- | Library dependencies proper only+-- | Library dependencies proper only. libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (== ComponentLib)+libraryDeps = select (\c -> case c of ComponentLib _ -> True+                                      _ -> False) --- | Setup dependencies+-- | Setup dependencies. setupDeps :: Monoid a => ComponentDeps a -> a setupDeps = select (== ComponentSetup) --- | Select dependencies satisfying a given predicate+-- | Select dependencies satisfying a given predicate. select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a select p = foldMap snd . filter (p . fst) . toList
cabal/cabal-install/Distribution/Client/Config.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonoLocalBinds #-}  ----------------------------------------------------------------------------- -- |@@ -16,6 +17,7 @@ module Distribution.Client.Config (     SavedConfig(..),     loadConfig,+    getConfigFilePath,      showConfig,     showConfigWithComments,@@ -37,7 +39,10 @@     withProgramsFields,     withProgramOptionsFields,     userConfigDiff,-    userConfigUpdate+    userConfigUpdate,+    createDefaultConfigFile,++    remoteRepoFields   ) where  import Distribution.Client.Types@@ -60,6 +65,7 @@          ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , AllowNewer(..)          , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , installDirsOptions, optionDistPref          , programConfigurationPaths', programConfigurationOptions@@ -73,9 +79,11 @@          , locatedErrorMsg, showPWarning          , readFields, warning, lineNo          , simpleField, listField, spaceListField-         , parseFilePathQ, parseTokenQ )+         , parseFilePathQ, parseOptCommaList, parseTokenQ ) import Distribution.Client.ParseUtils          ( parseFields, ppFields, ppSection )+import Distribution.Client.HttpUtils+         ( isOldHackageURI ) import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) ) import qualified Distribution.Text as Text@@ -96,14 +104,11 @@          ( partition, find, foldl' ) import Data.Maybe          ( fromMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif import Control.Monad-         ( unless, foldM, liftM, liftM2 )+         ( when, unless, foldM, liftM, liftM2 ) import qualified Distribution.Compat.ReadP as Parse-         ( option )+         ( (<++), option )+import Distribution.Compat.Semigroup import qualified Text.PrettyPrint as Disp          ( render, text, empty ) import Text.PrettyPrint@@ -133,6 +138,7 @@          ( on ) import Data.List          ( nubBy )+import GHC.Generics ( Generic )  -- -- * Configuration saved in the config file@@ -148,21 +154,14 @@     savedUploadFlags       :: UploadFlags,     savedReportFlags       :: ReportFlags,     savedHaddockFlags      :: HaddockFlags-  }+  } deriving Generic  instance Monoid SavedConfig where-  mempty = SavedConfig {-    savedGlobalFlags       = mempty,-    savedInstallFlags      = mempty,-    savedConfigureFlags    = mempty,-    savedConfigureExFlags  = mempty,-    savedUserInstallDirs   = mempty,-    savedGlobalInstallDirs = mempty,-    savedUploadFlags       = mempty,-    savedReportFlags       = mempty,-    savedHaddockFlags      = mempty-  }-  mappend a b = SavedConfig {+  mempty = gmempty+  mappend = (<>)++instance Semigroup SavedConfig where+  a <> b = SavedConfig {     savedGlobalFlags       = combinedSavedGlobalFlags,     savedInstallFlags      = combinedSavedInstallFlags,     savedConfigureFlags    = combinedSavedConfigureFlags,@@ -195,6 +194,11 @@       combine'        field subfield =         (subfield . field $ a) `mappend` (subfield . field $ b) +      combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)+                    -> mon+      combineMonoid field subfield =+        (subfield . field $ a) `mappend` (subfield . field $ b)+       lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]       lastNonEmpty'   field subfield =         let a' = subfield . field $ a@@ -215,6 +219,7 @@         globalNumericVersion    = combine globalNumericVersion,         globalConfigFile        = combine globalConfigFile,         globalSandboxConfigFile = combine globalSandboxConfigFile,+        globalConstraintsFile   = combine globalConstraintsFile,         globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,         globalCacheDir          = combine globalCacheDir,         globalLocalRepos        = lastNonEmptyNL globalLocalRepos,@@ -222,6 +227,7 @@         globalWorldFile         = combine globalWorldFile,         globalRequireSandbox    = combine globalRequireSandbox,         globalIgnoreSandbox     = combine globalIgnoreSandbox,+        globalIgnoreExpiry      = combine globalIgnoreExpiry,         globalHttpTransport     = combine globalHttpTransport         }         where@@ -259,7 +265,7 @@           lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags        combinedSavedConfigureFlags = ConfigFlags {-        configPrograms            = configPrograms . savedConfigureFlags $ b,+        configPrograms_           = configPrograms_ . savedConfigureFlags $ b,         -- TODO: NubListify         configProgramPaths        = lastNonEmpty configProgramPaths,         -- TODO: NubListify@@ -290,7 +296,10 @@         -- TODO: NubListify         configExtraLibDirs        = lastNonEmpty configExtraLibDirs,         -- TODO: NubListify+        configExtraFrameworkDirs  = lastNonEmpty configExtraFrameworkDirs,+        -- TODO: NubListify         configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,+        configIPID                = combine configIPID,         configDistPref            = combine configDistPref,         configVerbosity           = combine configVerbosity,         configUserInstall         = combine configUserInstall,@@ -304,7 +313,6 @@         configConstraints         = lastNonEmpty configConstraints,         -- TODO: NubListify         configDependencies        = lastNonEmpty configDependencies,-        configInstantiateWith     = lastNonEmpty configInstantiateWith,         -- TODO: NubListify         configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,         configTests               = combine configTests,@@ -313,7 +321,9 @@         configLibCoverage         = combine configLibCoverage,         configExactConfiguration  = combine configExactConfiguration,         configFlagError           = combine configFlagError,-        configRelocatable         = combine configRelocatable+        configRelocatable         = combine configRelocatable,+        configAllowNewer          = combineMonoid savedConfigureFlags+                                    configAllowNewer         }         where           combine        = combine'        savedConfigureFlags@@ -326,8 +336,7 @@         configExConstraints = lastNonEmpty configExConstraints,         -- TODO: NubListify         configPreferences   = lastNonEmpty configPreferences,-        configSolver        = combine configSolver,-        configAllowNewer    = combine configAllowNewer+        configSolver        = combine configSolver         }         where           combine      = combine' savedConfigureExFlags@@ -343,6 +352,7 @@        combinedSavedUploadFlags = UploadFlags {         uploadCheck       = combine uploadCheck,+        uploadDoc         = combine uploadDoc,         uploadUsername    = combine uploadUsername,         uploadPassword    = combine uploadPassword,         uploadPasswordCmd = combine uploadPasswordCmd,@@ -367,6 +377,7 @@         haddockHoogle        = combine haddockHoogle,         haddockHtml          = combine haddockHtml,         haddockHtmlLocation  = combine haddockHtmlLocation,+        haddockForHackage    = combine haddockForHackage,         haddockExecutables   = combine haddockExecutables,         haddockTestSuites    = combine haddockTestSuites,         haddockBenchmarks    = combine haddockBenchmarks,@@ -481,7 +492,7 @@ -- global installs on Windows but that no longer works on Windows Vista or 7.  defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri () False+defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False   where     name = "hackage.haskell.org"     uri  = URI "http:" (Just (URIAuth "" name "")) "/" "" ""@@ -490,10 +501,6 @@     -- but new config files can use the new url (without the /packages/archive)     -- and avoid having to do a http redirect -    -- Use this as a source for crypto credentials when finding old remote-repo-    -- entries that match repo name and url (not only be used for generating-    -- fresh config files).- -- For the default repo we know extra information, fill this in. -- -- We need this because the 'defaultRemoteRepo' above is only used for the@@ -501,12 +508,15 @@ -- we might have only have older info. This lets us fill that in even for old -- config files. --+-- TODO: Once we migrate from opt-in to opt-out security for the central+-- Hackage repository, we should enable security and specify keys and threshold+-- for repositories that have their security setting as 'Nothing' (default). addInfoForKnownRepos :: RemoteRepo -> RemoteRepo addInfoForKnownRepos repo@RemoteRepo{ remoteRepoName = "hackage.haskell.org" } =-    repo {-      --remoteRepoRootKeys --TODO: when this list is empty, fill in known crypto credentials-      remoteRepoShouldTryHttps = True-    }+      tryHttps+    $ if isOldHackageURI (remoteRepoURI repo) then defaultRemoteRepo else repo+  where+    tryHttps r = r { remoteRepoShouldTryHttps = True } addInfoForKnownRepos other = other  --@@ -515,26 +525,14 @@  loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig loadConfig verbosity configFileFlag = addBaseConf $ do-  let sources = [-        ("commandline option",   return . flagToMaybe $ configFileFlag),-        ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),-        ("default config file",  Just `liftM` defaultConfigFile) ]--      getSource [] = error "no config file path candidate found."-      getSource ((msg,action): xs) =-                        action >>= maybe (getSource xs) (return . (,) msg)--  (source, configFile) <- getSource sources+  (source, configFile) <- getConfigFilePathAndSource configFileFlag   minp <- readConfigFile mempty configFile   case minp of     Nothing -> do-      notice verbosity $ "Config file path source is " ++ source ++ "."+      notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."       notice verbosity $ "Config file " ++ configFile ++ " not found."-      notice verbosity $ "Writing default configuration to " ++ configFile-      commentConf <- commentSavedConfig-      initialConf <- initialSavedConfig-      writeConfigFile configFile commentConf initialConf-      return initialConf+      createDefaultConfigFile verbosity configFile+      loadConfig verbosity configFileFlag     Just (ParseOk ws conf) -> do       unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)@@ -551,6 +549,32 @@       extra <- body       return (base `mappend` extra) +    sourceMsg CommandlineOption =   "commandline option"+    sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"+    sourceMsg Default =             "default config file"++data ConfigFileSource = CommandlineOption+                      | EnvironmentVariable+                      | Default++-- | Returns the config file path, without checking that the file exists.+-- The order of precedence is: input flag, CABAL_CONFIG, default location.+getConfigFilePath :: Flag FilePath -> IO FilePath+getConfigFilePath = fmap snd . getConfigFilePathAndSource++getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)+getConfigFilePathAndSource configFileFlag =+    getSource sources+  where+    sources =+      [ (CommandlineOption,   return . flagToMaybe $ configFileFlag)+      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)+      , (Default,             Just `liftM` defaultConfigFile) ]++    getSource [] = error "no config file path candidate found."+    getSource ((source,action): xs) =+                      action >>= maybe (getSource xs) (return . (,) source)+ readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $   fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)@@ -562,6 +586,13 @@         then return Nothing         else ioError ioe +createDefaultConfigFile :: Verbosity -> FilePath -> IO ()+createDefaultConfigFile verbosity filePath = do+  commentConf <- commentSavedConfig+  initialConf <- initialSavedConfig+  notice verbosity $ "Writing default configuration to " ++ filePath+  writeConfigFile filePath commentConf initialConf+ writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do   let tmpFile = file <.> "tmp"@@ -598,7 +629,8 @@     savedInstallFlags      = defaultInstallFlags,     savedConfigureExFlags  = defaultConfigExFlags,     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {-      configUserInstall    = toFlag defaultUserInstall+      configUserInstall    = toFlag defaultUserInstall,+      configAllowNewer     = Just AllowNewerNone     },     savedUserInstallDirs   = fmap toFlag userInstallDirs,     savedGlobalInstallDirs = fmap toFlag globalInstallDirs,@@ -618,21 +650,34 @@    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "constraint", "dependency"]+       (["builddir", "constraint", "dependency", "ipid"]         ++ map fieldName installDirsFields) -        --FIXME: this is only here because viewAsFieldDescr gives us a parser+        -- This is only here because viewAsFieldDescr gives us a parser         -- that only recognises 'ghc' etc, the case-sensitive flag names, not         -- what the normal case-insensitive parser gives us.        [simpleField "compiler"           (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)           configHcFlavor (\v flags -> flags { configHcFlavor = v })+       ,let showAllowNewer Nothing               = mempty+            showAllowNewer (Just AllowNewerNone) = Disp.text "False"+            showAllowNewer (Just _)              = Disp.text "True"++            toAllowNewer True  = Just AllowNewerAll+            toAllowNewer False = Just AllowNewerNone++            pkgs = (Just . AllowNewerSome) `fmap` parseOptCommaList Text.parse+            parseAllowNewer = (toAllowNewer `fmap` Text.parse) Parse.<++ pkgs in+        simpleField "allow-newer"+        showAllowNewer parseAllowNewer+        configAllowNewer (\v flags -> flags { configAllowNewer = v })         -- TODO: The following is a temporary fix. The "optimization"         -- and "debug-info" fields are OptArg, and viewAsFieldDescr         -- fails on that. Instead of a hand-written hackaged parser         -- and printer, we should handle this case properly in the         -- library.-       ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $+       ,liftField configOptimization (\v flags ->+                                       flags { configOptimization = v }) $         let name = "optimization" in         FieldDescr name           (\f -> case f of@@ -652,7 +697,8 @@              where                lstr = lowercase str                caseWarning = PWarning $-                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")        ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $         let name = "debug-info" in         FieldDescr name@@ -675,7 +721,8 @@              where                lstr = lowercase str                caseWarning = PWarning $-                 "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")        ]    ++ toSavedConfig liftConfigExFlag@@ -688,7 +735,7 @@    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)-       ["verbose", "check"] []+       ["verbose", "check", "documentation"] []    ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)@@ -703,8 +750,10 @@        (configDistPref . savedConfigureFlags)        (\distPref config ->           config-          { savedConfigureFlags = (savedConfigureFlags config) { configDistPref = distPref }-          , savedHaddockFlags = (savedHaddockFlags config) { haddockDistPref = distPref }+          { savedConfigureFlags = (savedConfigureFlags config) {+               configDistPref = distPref }+          , savedHaddockFlags = (savedHaddockFlags config) {+               haddockDistPref = distPref }           }        )        ParseArgs@@ -825,7 +874,7 @@   }    where-    isKnownSection (ParseUtils.Section _ "remote-repo" _ _)             = True+    isKnownSection (ParseUtils.Section _ "repository" _ _)              = True     isKnownSection (ParseUtils.F _ "remote-repo" _)                     = True     isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True     isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True@@ -837,8 +886,15 @@                       ++ deprecatedFieldDescriptions) initial      parseSections (rs, h, u, g, p, a)-                 (ParseUtils.Section _ "remote-repo" name fs) = do+                 (ParseUtils.Section _ "repository" name fs) = do       r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs+      when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $+        warning $ "'key-threshold' for repository " ++ show (remoteRepoName r')+               ++ " higher than number of keys"+      when (not (null (remoteRepoRootKeys r'))+            && remoteRepoSecure r' /= Just True) $+        warning $ "'root-keys' for repository " ++ show (remoteRepoName r')+               ++ " non-empty, but 'secure' not set to True."       return (r':rs, h, u, g, p, a)      parseSections (rs, h, u, g, p, a)@@ -887,7 +943,8 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos . savedGlobalFlags $ vals of+      case fmap ppRemoteRepoSection . fromNubList . globalRemoteRepos+           . savedGlobalFlags $ vals of         [] -> Disp.text ""         (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs   $+$ Disp.text ""@@ -925,20 +982,43 @@ installDirsFields = map viewAsFieldDescr installDirsOptions  ppRemoteRepoSection :: RemoteRepo -> Doc-ppRemoteRepoSection vals = ppSection "remote-repo" (remoteRepoName vals)-        remoteRepoFields Nothing vals+ppRemoteRepoSection vals = ppSection "repository" (remoteRepoName vals)+        remoteRepoFields def vals+  where+    def = Just (emptyRemoteRepo "ignored") { remoteRepoSecure = Just False }  remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields =-    [ FieldDescr { fieldName = "url",-                   fieldGet = text . show . remoteRepoURI,-                   fieldSet = \ _ uriString remoteRepo -> maybe-                          (fail $ "remote-repo: no parse on " ++ show uriString)-                          (\ uri -> return $ remoteRepo { remoteRepoURI = uri })-                          (parseURI uriString)-                 }+    [ simpleField "url"+        (text . show)            (parseTokenQ >>= parseURI')+        remoteRepoURI            (\x repo -> repo { remoteRepoURI = x })+    , simpleField "secure"+        showSecure               (Just `fmap` Text.parse)+        remoteRepoSecure         (\x repo -> repo { remoteRepoSecure = x })+    , listField "root-keys"+        text                     parseTokenQ+        remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })+    , simpleField "key-threshold"+        showThreshold            Text.parse+        remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })     ]+  where+    parseURI' uriString =+      case parseURI uriString of+        Nothing  -> fail $ "remote-repo: no parse on " ++ show uriString+        Just uri -> return uri +    showSecure  Nothing      = mempty       -- default 'secure' setting+    showSecure  (Just True)  = text "True"  -- user explicitly enabled it+    showSecure  (Just False) = text "False" -- user explicitly disabled it++    -- If the key-threshold is set to 0, we omit it as this is the default+    -- and it looks odd to have a value for key-threshold but not for 'secure'+    -- (note that an empty list of keys is already omitted by default, since+    -- that is what we do for all list fields)+    showThreshold 0 = mempty+    showThreshold t = text (show t)+ -- | Fields for the 'haddock' section. haddockFlagsFields :: [FieldDescr HaddockFlags] haddockFlagsFields = [ field@@ -978,12 +1058,14 @@      combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)     combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)-    combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y+    combine x y = error $ "Can't happen : userConfigDiff "+                  ++ show x ++ " " ++ show y      createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]     createDiff acc (key, (Just a, Just b))         | a == b = acc-        | otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc+        | otherwise = ("+ " ++ key ++ ": " ++ b)+                      : ("- " ++ key ++ ": " ++ a) : acc     createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc     createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc     createDiff acc (_, (Nothing, Nothing)) = acc@@ -1012,7 +1094,7 @@   userConfig <- loadConfig normal (globalConfigFile globalFlags)   newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig   commentConf <- commentSavedConfig-  cabalFile <- defaultConfigFile+  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags   let backup = cabalFile ++ ".backup"   notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."   renameFile cabalFile backup
cabal/cabal-install/Distribution/Client/Configure.hs view
@@ -20,15 +20,17 @@  import Distribution.Client.Dependency import Distribution.Client.Dependency.Types-         ( AllowNewer(..), isAllowNewer, ConstraintSource(..)+         ( ConstraintSource(..)          , LabeledPackageConstraint(..), showConstraintSource ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import Distribution.Client.PackageIndex ( PackageIndex, elemByPackageName )+import Distribution.Client.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Client.Setup-         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )+         ( ConfigExFlags(..), configureCommand, filterConfigureFlags+         , RepoContext(..) ) import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )@@ -42,14 +44,14 @@          ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup-         ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )+         ( ConfigFlags(..), AllowNewer(..)+         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex          ( InstalledPackageIndex, lookupPackageName ) import Distribution.Simple.Utils          ( defaultPackageDesc )-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( Package(..), InstalledPackageId, packageName+         ( Package(..), UnitId, packageName          , Dependency(..), thisPackageVersion          ) import qualified Distribution.PackageDescription as PkgDesc@@ -60,7 +62,9 @@ import Distribution.Version          ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( warn, notice, info, debug, die )+         ( warn, notice, debug, die )+import Distribution.Simple.Setup+         ( isAllowNewer ) import Distribution.System          ( Platform ) import Distribution.Text ( display )@@ -77,14 +81,14 @@  -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags.-chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange-chooseCabalVersion configExFlags maybeVersion =+chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange+chooseCabalVersion configFlags maybeVersion =   maybe defaultVersionRange thisVersion maybeVersion   where     -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed     -- for '--allow-newer' to work.-    allowNewer = fromFlagOrDefault False $-                 fmap isAllowNewer (configAllowNewer configExFlags)+    allowNewer = isAllowNewer+                 (fromMaybe AllowNewerNone $ configAllowNewer configFlags)      defaultVersionRange = if allowNewer                           then orLaterVersion (Version [1,19,2] [])@@ -93,7 +97,7 @@ -- | Configure the package found in the local directory configure :: Verbosity           -> PackageDBStack-          -> [Repo]+          -> RepoContext           -> Compiler           -> Platform           -> ProgramConfiguration@@ -101,24 +105,26 @@           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repos comp platform conf+configure verbosity packageDBs repoCtxt comp platform conf   configFlags configExFlags extraArgs = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-  sourcePkgDb       <- getSourcePackages    verbosity repos+  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+  pkgConfigDb       <- readPkgConfigDb      verbosity conf+   checkConfigExFlags verbosity installedPkgIndex                      (packageIndex sourcePkgDb) configExFlags    progress <- planLocalPackage verbosity comp platform configFlags configExFlags-                               installedPkgIndex sourcePkgDb+                               installedPkgIndex sourcePkgDb pkgConfigDb    notice verbosity "Resolving dependencies..."   maybePlan <- foldProgress logMsg (return . Left) (return . Right)                             progress   case maybePlan of     Left message -> do-      info verbosity $-           "Warning: solver failed to find a solution:\n"+      warn verbosity $+           "solver failed to find a solution:\n"         ++ message         ++ "Trying configure anyway."       setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)@@ -127,8 +133,7 @@     Right installPlan -> case InstallPlan.ready installPlan of       [pkg@(ReadyPackage              (ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _)-                                 _ _ _)-             _)] -> do+                                 _ _ _))] -> do         configurePackage verbosity           platform (compilerInfo comp)           (setupScriptOptions installedPkgIndex (Just pkg))@@ -151,7 +156,7 @@            (useDistPref defaultSetupScriptOptions)            (configDistPref configFlags))         (chooseCabalVersion-           configExFlags+           configFlags            (flagToMaybe (configCabalVersion configExFlags)))         Nothing         False@@ -181,6 +186,7 @@                      mpkg   = SetupScriptOptions {       useCabalVersion   = cabalVersion+    , useCabalSpecVersion = Nothing     , useCompiler       = Just comp     , usePlatform       = Just platform     , usePackageDB      = packageDBs'@@ -200,6 +206,7 @@       -- Therefore, for now, we just leave this blank.     , useDependencies          = fromMaybe [] explicitSetupDeps     , useDependenciesExclusive = isJust explicitSetupDeps+    , useVersionMacros         = isJust explicitSetupDeps     }   where     -- When we are compiling a legacy setup script without an explicit@@ -217,17 +224,15 @@         -- but if the user is using an odd db stack, don't touch it         _otherwise -> (packageDBs, Just index) -    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]+    explicitSetupDeps :: Maybe [(UnitId, PackageId)]     explicitSetupDeps = do-      ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _) _ _ _) deps-                 <- mpkg+      ReadyPackage cpkg <- mpkg+      let gpkg = packageDescription (confPkgSource cpkg)       -- Check if there is an explicit setup stanza       _buildInfo <- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)       -- Return the setup dependencies computed by the solver-      return [ ( Installed.installedPackageId deppkg-               , Installed.sourcePackageId    deppkg-               )-             | deppkg <- CD.setupDeps deps+      return [ ( uid, srcid )+             | ConfiguredId srcid uid <- CD.setupDeps (confPkgDeps cpkg)              ]  -- | Warn if any constraints or preferences name packages that are not in the@@ -263,10 +268,10 @@                  -> ConfigFlags -> ConfigExFlags                  -> InstalledPackageIndex                  -> SourcePackageDb+                 -> PkgConfigDb                  -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags-  installedPkgIndex-  (SourcePackageDb _ packagePrefs) = do+  installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity   solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)             (compilerInfo comp)@@ -284,8 +289,8 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =-          removeUpperBounds (fromFlagOrDefault AllowNewerNone $-                             configAllowNewer configExFlags)+          removeUpperBounds+          (fromMaybe AllowNewerNone $ configAllowNewer configFlags)          . addPreferences             -- preferences from the config file or command line@@ -320,7 +325,7 @@             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies platform (compilerInfo comp) solver resolverParams)+  return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)   -- | Call an installer for an 'SourcePackage' but override the configure@@ -339,25 +344,23 @@                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-                 (ReadyPackage (ConfiguredPackage (SourcePackage _ gpkg _ _)-                                                  flags stanzas _)-                               deps)+                 (ReadyPackage (ConfiguredPackage spkg flags stanzas deps))                  extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs    where+    gpkg = packageDescription spkg     configureFlags   = filterConfigureFlags configFlags {       configConfigurationsFlags = flags,       -- We generate the legacy constraints as well as the new style precise       -- deps.  In the end only one set gets passed to Setup.hs configure,       -- depending on the Cabal version we are talking to.-      configConstraints  = [ thisPackageVersion (packageId deppkg)-                           | deppkg <- CD.nonSetupDeps deps ],-      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                              Installed.installedPackageId deppkg)-                           | deppkg <- CD.nonSetupDeps deps ],+      configConstraints  = [ thisPackageVersion srcid+                           | ConfiguredId srcid _uid <- CD.nonSetupDeps deps ],+      configDependencies = [ (packageName srcid, uid)+                           | ConfiguredId srcid uid <- CD.nonSetupDeps deps ],       -- Use '--exact-configuration' if supported.       configExactConfiguration = toFlag True,       configVerbosity          = toFlag verbosity,
cabal/cabal-install/Distribution/Client/Dependency.hs view
@@ -53,10 +53,11 @@     setStrongFlags,     setMaxBackjumps,     addSourcePackages,-    hideInstalledPackagesSpecificByInstalledPackageId,+    hideInstalledPackagesSpecificByUnitId,     hideInstalledPackagesSpecificBySourcePackageId,     hideInstalledPackagesAllVersions,-    removeUpperBounds+    removeUpperBounds,+    addDefaultSetupDependencies,   ) where  import Distribution.Client.Dependency.TopDown@@ -68,15 +69,18 @@ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.PkgConfigDb (PkgConfigDb) import Distribution.Client.Types          ( SourcePackageDb(SourcePackageDb), SourcePackage(..)-         , ConfiguredPackage(..), ConfiguredId(..), enableStanzas )+         , ConfiguredPackage(..), ConfiguredId(..)+         , UnresolvedPkgLoc, UnresolvedSourcePackage+         , OptionalStanza(..), enableStanzas ) import Distribution.Client.Dependency.Types          ( PreSolver(..), Solver(..), DependencyResolver, ResolverPackage(..)          , PackageConstraint(..), showPackageConstraint          , LabeledPackageConstraint(..), unlabelPackageConstraint          , ConstraintSource(..), showConstraintSource-         , AllowNewer(..), PackagePreferences(..), InstalledPreference(..)+         , PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress ) import Distribution.Client.Sandbox.Types@@ -88,20 +92,18 @@ import Distribution.Package          ( PackageName(..), PackageIdentifier(PackageIdentifier), PackageId          , Package(..), packageName, packageVersion-         , InstalledPackageId, Dependency(Dependency))+         , UnitId, Dependency(Dependency)) import qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), Library(..), Executable(..)-         , TestSuite(..), Benchmark(..), SetupBuildInfo(..)-         , GenericPackageDescription(..), CondTree+         ( PackageDescription(..), SetupBuildInfo(..)+         , GenericPackageDescription(..)          , Flag(flagName), FlagName(..) )-import Distribution.PackageDescription (BuildInfo(targetBuildDepends)) import Distribution.PackageDescription.Configuration-         ( mapCondTree, finalizePackageDescription )+         ( finalizePackageDescription ) import Distribution.Client.PackageUtils          ( externalBuildDepends ) import Distribution.Version          ( VersionRange, anyVersion, thisVersion, withinRange-         , removeUpperBound, simplifyVersionRange )+         , simplifyVersionRange ) import Distribution.Compiler          ( CompilerInfo(..) ) import Distribution.System@@ -110,13 +112,17 @@          ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing, warn, info )+import Distribution.Simple.Configure+         ( relaxPackageDeps )+import Distribution.Simple.Setup+         ( AllowNewer(..) ) import Distribution.Text          ( display ) import Distribution.Verbosity          ( Verbosity )  import Data.List-         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate )+         ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on) import Data.Maybe (fromMaybe) import qualified Data.Map as Map@@ -140,7 +146,7 @@        depResolverPreferences       :: [PackagePreference],        depResolverPreferenceDefault :: PackagesPreferenceDefault,        depResolverInstalledPkgIndex :: InstalledPackageIndex,-       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex SourcePackage,+       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,        depResolverReorderGoals      :: Bool,        depResolverIndependentGoals  :: Bool,        depResolverAvoidReinstalls   :: Bool,@@ -158,7 +164,14 @@   ++ "\npreferences: "   ++   concatMap (("\n  " ++) . showPackagePreference)        (depResolverPreferences p)-  ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)+  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault p)+  ++ "\nreorder goals: "     ++ show (depResolverReorderGoals      p)+  ++ "\nindependent goals: " ++ show (depResolverIndependentGoals  p)+  ++ "\navoid reinstalls: "  ++ show (depResolverAvoidReinstalls   p)+  ++ "\nshadow packages: "   ++ show (depResolverShadowPkgs        p)+  ++ "\nstrong flags: "      ++ show (depResolverStrongFlags       p)+  ++ "\nmax backjumps: "     ++ maybe "infinite" show+                                     (depResolverMaxBackjumps      p)   where     showLabeledConstraint :: LabeledPackageConstraint -> String     showLabeledConstraint (LabeledPackageConstraint pc src) =@@ -178,6 +191,11 @@      -- | If we prefer versions of packages that are already installed.    | PackageInstalledPreference PackageName InstalledPreference +     -- | If we would prefer to enable these optional stanzas+     -- (i.e. test suites and/or benchmarks)+   | PackageStanzasPreference   PackageName [OptionalStanza]++ -- | Provide a textual representation of a package preference -- for debugging purposes. --@@ -186,9 +204,11 @@   display pn ++ " " ++ display (simplifyVersionRange vr) showPackagePreference (PackageInstalledPreference pn ip) =   display pn ++ " " ++ show ip+showPackagePreference (PackageStanzasPreference pn st) =+  display pn ++ " " ++ show st  basicDepResolverParams :: InstalledPackageIndex-                       -> PackageIndex.PackageIndex SourcePackage+                       -> PackageIndex.PackageIndex UnresolvedSourcePackage                        -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex =     DepResolverParams {@@ -282,7 +302,7 @@       [ LabeledPackageConstraint         (PackageConstraintInstalled pkgname)         ConstraintSourceNonUpgradeablePackage-      | all (/=PackageName "base") (depResolverTargets params)+      | notElem (PackageName "base") (depResolverTargets params)       , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"                                    , "integer-simple" ]       , isInstalled pkgname ]@@ -293,7 +313,7 @@                 . InstalledPackageIndex.lookupPackageName                                  (depResolverInstalledPkgIndex params) -addSourcePackages :: [SourcePackage]+addSourcePackages :: [UnresolvedSourcePackage]                   -> DepResolverParams -> DepResolverParams addSourcePackages pkgs params =     params {@@ -302,14 +322,14 @@               (depResolverSourcePkgIndex params) pkgs     } -hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]+hideInstalledPackagesSpecificByUnitId :: [UnitId]                                                      -> DepResolverParams                                                      -> DepResolverParams-hideInstalledPackagesSpecificByInstalledPackageId pkgids params =+hideInstalledPackagesSpecificByUnitId pkgids params =     --TODO: this should work using exclude constraints instead     params {       depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)+        foldl' (flip InstalledPackageIndex.deleteUnitId)                (depResolverInstalledPkgIndex params) pkgids     } @@ -337,96 +357,68 @@  hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams hideBrokenInstalledPackages params =-    hideInstalledPackagesSpecificByInstalledPackageId pkgids params+    hideInstalledPackagesSpecificByUnitId pkgids params   where-    pkgids = map Installed.installedPackageId+    pkgids = map Installed.installedUnitId            . InstalledPackageIndex.reverseDependencyClosure                             (depResolverInstalledPkgIndex params)-           . map (Installed.installedPackageId . fst)+           . map (Installed.installedUnitId . fst)            . InstalledPackageIndex.brokenPackages            $ depResolverInstalledPkgIndex params  -- | Remove upper bounds in dependencies using the policy specified by the -- 'AllowNewer' argument (all/some/none).+--+-- Note: It's important to apply 'removeUpperBounds' after+-- 'addSourcePackages'. Otherwise, the packages inserted by+-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.+-- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds allowNewer params =+removeUpperBounds AllowNewerNone params = params+removeUpperBounds allowNewer     params =     params {-      -- NB: It's important to apply 'removeUpperBounds' after-      -- 'addSourcePackages'. Otherwise, the packages inserted by-      -- 'addSourcePackages' won't have upper bounds in dependencies relaxed.-       depResolverSourcePkgIndex = sourcePkgIndex'     }   where-    sourcePkgIndex  = depResolverSourcePkgIndex params-    sourcePkgIndex' = case allowNewer of-      AllowNewerNone      -> sourcePkgIndex-      AllowNewerAll       -> fmap relaxAllPackageDeps         sourcePkgIndex-      AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex--    relaxAllPackageDeps :: SourcePackage -> SourcePackage-    relaxAllPackageDeps = onAllBuildDepends doRelax-      where-        doRelax (Dependency pkgName verRange) =-          Dependency pkgName (removeUpperBound verRange)--    relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage-    relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax-      where-        doRelax d@(Dependency pkgName verRange)-          | pkgName `elem` pkgNames = Dependency pkgName-                                      (removeUpperBound verRange)-          | otherwise               = d--    -- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'-    -- fields.-    onAllBuildDepends :: (Dependency -> Dependency)-                      -> SourcePackage -> SourcePackage-    onAllBuildDepends f srcPkg = srcPkg'-      where-        gpd        = packageDescription srcPkg-        pd         = PD.packageDescription gpd-        condLib    = PD.condLibrary        gpd-        condExes   = PD.condExecutables    gpd-        condTests  = PD.condTestSuites     gpd-        condBenchs = PD.condBenchmarks     gpd--        f' = onBuildInfo f-        onBuildInfo g bi = bi-          { targetBuildDepends = map g (targetBuildDepends bi) }+    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params -        onLibrary    lib  = lib { PD.libBuildInfo  = f' $ PD.libBuildInfo  lib }-        onExecutable exe  = exe { PD.buildInfo     = f' $ PD.buildInfo     exe }-        onTestSuite  tst  = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }-        onBenchmark  bmk  = bmk { PD.benchmarkBuildInfo =-                                     f' $ PD.benchmarkBuildInfo bmk }+    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    relaxDeps srcPkg = srcPkg {+      packageDescription = relaxPackageDeps allowNewer+                           (packageDescription srcPkg)+      } -        srcPkg' = srcPkg { packageDescription = gpd' }-        gpd'    = gpd {-          PD.packageDescription = pd',-          PD.condLibrary        = condLib',-          PD.condExecutables    = condExes',-          PD.condTestSuites     = condTests',-          PD.condBenchmarks     = condBenchs'-          }-        pd' = pd {-          PD.buildDepends = map  f            (PD.buildDepends pd),-          PD.library      = fmap onLibrary    (PD.library pd),-          PD.executables  = map  onExecutable (PD.executables pd),-          PD.testSuites   = map  onTestSuite  (PD.testSuites pd),-          PD.benchmarks   = map  onBenchmark  (PD.benchmarks pd)+-- | Supply defaults for packages without explicit Setup dependencies+--+-- Note: It's important to apply 'addDefaultSetupDepends' after+-- 'addSourcePackages'. Otherwise, the packages inserted by+-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.+--+addDefaultSetupDependencies :: (UnresolvedSourcePackage -> [Dependency])+                            -> DepResolverParams -> DepResolverParams+addDefaultSetupDependencies defaultSetupDeps params =+    params {+      depResolverSourcePkgIndex =+        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)+    }+  where+    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    applyDefaultSetupDeps srcpkg =+        srcpkg {+          packageDescription = gpkgdesc {+            PD.packageDescription = pkgdesc {+              PD.setupBuildInfo =+                case PD.setupBuildInfo pkgdesc of+                  Just sbi -> Just sbi+                  Nothing  -> Just PD.SetupBuildInfo {+                                PD.setupDepends = defaultSetupDeps srcpkg+                              }+            }           }-        condLib'    = fmap (onCondTree onLibrary)             condLib-        condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes-        condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests-        condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs--        mapSnd :: (a -> b) -> (c,a) -> (c,b)-        mapSnd = fmap--        onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a-                   -> PD.CondTree v [Dependency] b-        onCondTree g = mapCondTree g (map f) id+        }+      where+        gpkgdesc = packageDescription srcpkg+        pkgdesc  = PD.packageDescription gpkgdesc   upgradeDependencies :: DepResolverParams -> DepResolverParams@@ -440,7 +432,7 @@  standardInstallPolicy :: InstalledPackageIndex                       -> SourcePackageDb-                      -> [PackageSpecifier SourcePackage]+                      -> [PackageSpecifier UnresolvedSourcePackage]                       -> DepResolverParams standardInstallPolicy     installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)@@ -521,7 +513,7 @@         info verbosity "Choosing modular solver."         return Modular -runSolver :: Solver -> SolverConfig -> DependencyResolver+runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options runSolver Modular = modularResolver @@ -533,25 +525,26 @@ -- resolveDependencies :: Platform                     -> CompilerInfo+                    -> PkgConfigDb                     -> Solver                     -> DepResolverParams                     -> Progress String String InstallPlan      --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages-resolveDependencies platform comp _solver params+resolveDependencies platform comp _pkgConfigDB _solver params   | null (depResolverTargets params)   = return (validateSolverResult platform comp indGoals [])   where     indGoals = depResolverIndependentGoals params -resolveDependencies platform comp  solver params =+resolveDependencies platform comp pkgConfigDB solver params =      Step (showDepResolverParams finalparams)   $ fmap (validateSolverResult platform comp indGoals)   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls                       shadowing strFlags maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex-                     preferences constraints targets+                     pkgConfigDB preferences constraints targets   where      finalparams @ (DepResolverParams@@ -586,14 +579,15 @@                             -> [PackagePreference]                             -> (PackageName -> PackagePreferences) interpretPackagesPreference selected defaultPref prefs =-  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)-+  \pkgname -> PackagePreferences (versionPref pkgname)+                                 (installPref pkgname)+                                 (stanzasPref pkgname)   where     versionPref pkgname =-      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)-    versionPrefs = Map.fromList-      [ (pkgname, pref)-      | PackageVersionPreference pkgname pref <- prefs ]+      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromListWith (++)+                   [(pkgname, [pref])+                   | PackageVersionPreference pkgname pref <- prefs]      installPref pkgname =       fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)@@ -601,14 +595,21 @@       [ (pkgname, pref)       | PackageInstalledPreference pkgname pref <- prefs ]     installPrefDefault = case defaultPref of-      PreferAllLatest         -> \_       -> PreferLatest-      PreferAllInstalled      -> \_       -> PreferInstalled+      PreferAllLatest         -> const PreferLatest+      PreferAllInstalled      -> const PreferInstalled       PreferLatestForSelected -> \pkgname ->         -- When you say cabal install foo, what you really mean is, prefer the         -- latest version of foo, but the installed version of everything else         if pkgname `Set.member` selected then PreferLatest                                          else PreferInstalled +    stanzasPref pkgname =+      fromMaybe [] (Map.lookup pkgname stanzasPrefs)+    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))+      [ (pkgname, pref)+      | PackageStanzasPreference pkgname pref <- prefs ]++ -- ------------------------------------------------------------ -- * Checking the result of the solver -- ------------------------------------------------------------@@ -619,7 +620,7 @@ validateSolverResult :: Platform                      -> CompilerInfo                      -> Bool-                     -> [ResolverPackage]+                     -> [ResolverPackage UnresolvedPkgLoc]                      -> InstallPlan validateSolverResult platform comp indepGoals pkgs =     case planPackagesProblems platform comp pkgs of@@ -637,7 +638,7 @@     formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem     formatPlanProblems = formatProblemMessage . map InstallPlan.showPlanProblem -    formatProblemMessage problems = +    formatProblemMessage problems =       unlines $         "internal error: could not construct a valid install plan."       : "The proposed (invalid) plan contained the following problems:"@@ -647,7 +648,7 @@   data PlanPackageProblem =-       InvalidConfiguredPackage ConfiguredPackage [PackageProblem]+       InvalidConfiguredPackage (ConfiguredPackage UnresolvedPkgLoc) [PackageProblem]  showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =@@ -657,7 +658,7 @@              | problem <- packageProblems ]  planPackagesProblems :: Platform -> CompilerInfo-                     -> [ResolverPackage]+                     -> [ResolverPackage UnresolvedPkgLoc]                      -> [PlanPackageProblem] planPackagesProblems platform cinfo pkgs =      [ InvalidConfiguredPackage pkg packageProblems@@ -706,7 +707,7 @@ -- dependencies are satisfied by the specified packages. -- configuredPackageProblems :: Platform -> CompilerInfo-                          -> ConfiguredPackage -> [PackageProblem]+                          -> ConfiguredPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo   (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps') =      [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]@@ -787,14 +788,14 @@ -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams-                           -> Either [ResolveNoDepsError] [SourcePackage]+                           -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex                               _reorderGoals _indGoals _avoidReinstalls                               _shadowing _strFlags _maxBjumps) =     collectEithers (map selectPackage targets)   where-    selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage+    selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage     selectPackage pkgname       | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions       | otherwise    = Right $! maximumBy bestByPrefs choices@@ -807,7 +808,7 @@                                                          pkgDependency          -- Preferences-        PackagePreferences preferredVersions preferInstalled+        PackagePreferences preferredVersions preferInstalled _           = packagePreferences pkgname          bestByPrefs   = comparing $ \pkg ->@@ -818,7 +819,8 @@                            . InstalledPackageIndex.lookupSourcePackageId                                                      installedPkgIndex                            . packageId-        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions+        versionPref pkg = length . filter (packageVersion pkg `withinRange`) $+                          preferredVersions      packageConstraints :: PackageName -> VersionRange     packageConstraints pkgname =
cabal/cabal-install/Distribution/Client/Dependency/Modular.hs view
@@ -12,9 +12,7 @@ import Data.Map as M          ( fromListWith ) import Distribution.Client.Dependency.Modular.Assignment-         ( Assignment, toCPs )-import Distribution.Client.Dependency.Modular.Dependency-         ( RevDepMap )+         ( toCPs ) import Distribution.Client.Dependency.Modular.ConfiguredConversion          ( convCP ) import Distribution.Client.Dependency.Modular.IndexConversion@@ -26,18 +24,18 @@ import Distribution.Client.Dependency.Modular.Solver          ( SolverConfig(..), solve ) import Distribution.Client.Dependency.Types-         ( DependencyResolver, ResolverPackage+         ( DependencyResolver          , PackageConstraint(..), unlabelPackageConstraint ) import Distribution.System          ( Platform(..) )  -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after.-modularResolver :: SolverConfig -> DependencyResolver-modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =+modularResolver :: SolverConfig -> DependencyResolver loc+modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =   fmap (uncurry postprocess)      $ -- convert install plan   logToProgress (maxBackjumps sc) $ -- convert log format into progress format-  solve sc idx pprefs gcs pns+  solve sc cinfo idx pkgConfigDB pprefs gcs pns     where       -- Indices have to be converted into solver-specific uniform index.       idx    = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx@@ -47,7 +45,6 @@           pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])        -- Results have to be converted into an install plan.-      postprocess :: Assignment -> RevDepMap -> [ResolverPackage]       postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm)        -- Helper function to extract the PN from a constraint.
cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -1,4 +1,11 @@-module Distribution.Client.Dependency.Modular.Assignment where+module Distribution.Client.Dependency.Modular.Assignment+    ( Assignment(..)+    , FAssignment+    , SAssignment+    , PreAssignment(..)+    , extend+    , toCPs+    ) where  import Control.Applicative import Control.Monad@@ -8,6 +15,8 @@ import Data.Maybe import Prelude hiding (pi) +import Language.Haskell.Extension (Extension, Language)+ import Distribution.PackageDescription (FlagAssignment) -- from Cabal import Distribution.Client.Types (OptionalStanza) import Distribution.Client.Utils.LabeledGraph@@ -17,7 +26,6 @@ import Distribution.Client.Dependency.Modular.Configured import Distribution.Client.Dependency.Modular.Dependency import Distribution.Client.Dependency.Modular.Flag-import Distribution.Client.Dependency.Modular.Index import Distribution.Client.Dependency.Modular.Package import Distribution.Client.Dependency.Modular.Version @@ -53,14 +61,31 @@ -- -- Either returns a witness of the conflict that would arise during the merge, -- or the successfully extended assignment.-extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment-extend var pa qa = foldM (\ a (Dep qpn ci) ->-                     let ci' = M.findWithDefault (Constrained []) qpn a-                     in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of-                           Left (c, (d, d')) -> Left  (c, L.map (Dep qpn) (simplify (P qpn) d d'))-                           Right x           -> Right x)-                    pa qa+extend :: (Extension -> Bool) -- ^ is a given extension supported+       -> (Language  -> Bool) -- ^ is a given language supported+       -> (PN -> VR  -> Bool) -- ^ is a given pkg-config requirement satisfiable+       -> Goal QPN+       -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+extend extSupported langSupported pkgPresent goal@(Goal var _) = foldM extendSingle   where++    extendSingle :: PPreAssignment -> Dep QPN+                 -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment+    extendSingle a (Ext  ext )  =+      if extSupported  ext  then Right a+                            else Left (toConflictSet goal, [Ext ext])+    extendSingle a (Lang lang)  =+      if langSupported lang then Right a+                            else Left (toConflictSet goal, [Lang lang])+    extendSingle a (Pkg pn vr)  =+      if pkgPresent pn vr then Right a+                          else Left (toConflictSet goal, [Pkg pn vr])+    extendSingle a (Dep qpn ci) =+      let ci' = M.findWithDefault (Constrained []) qpn a+      in  case (\ x -> M.insert qpn x a) <$> merge ci' ci of+            Left (c, (d, d')) -> Left  (c, L.map (Dep qpn) (simplify (P qpn) d d'))+            Right x           -> Right x+     -- We're trying to remove trivial elements of the conflict. If we're just     -- making a choice pkg == instance, and pkg => pkg == instance is a part     -- of the conflict, then this info is clear from the context and does not@@ -123,37 +148,3 @@                                  (M.findWithDefault [] qpn sapp)                                  (depp' qpn))           ps---- | Finalize an assignment and a reverse dependency map.------ This is preliminary, and geared towards output right now.-finalize :: Index -> Assignment -> RevDepMap -> IO ()-finalize idx (A pa fa _) rdm =-  let-    -- get hold of the graph-    g  :: Graph Component-    vm :: Vertex -> ((), QPN, [(Component, QPN)])-    (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm))-    -- topsort the dependency graph, yielding a list of pkgs in the right order-    f :: [PI QPN]-    f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g))-    fapp :: Map QPN [(QFN, Bool)] -- flags per package-    fapp = M.fromListWith (++) $-           L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa-    -- print one instance-    ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp)-    -- print install status-    status :: PI QPN -> String-    status (PI (Q _ pn) _) =-      case insts of-        [] -> " (new)"-        vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")"-      where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $-                    M.keys (M.findWithDefault M.empty pn idx)-            isInstalled (I _ (Inst _ )) = True-            isInstalled _               = False-    -- print flag assignment-    pflags = unwords . L.map (uncurry showFBool)-  in-    -- show packages with associated flag assignments-    putStr (unlines (L.map ppi f))
cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs view
@@ -24,7 +24,8 @@ import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Index import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.PSQ (PSQ)+import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree  import Distribution.Client.ComponentDeps (Component)@@ -58,8 +59,11 @@       | qpn `M.member` g  = go (M.adjust ((c, qpn'):) qpn g)              o  ngs       | otherwise         = go (M.insert qpn [(c, qpn')]  g) (cons' ng () o) ngs           -- code above is correct; insert/adjust have different arg order+    go g o (   (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs+    go g o (   (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs -    cons' = cons . forgetCompOpenGoal+    cons' = P.cons . forgetCompOpenGoal  -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.@@ -114,6 +118,12 @@     --     -- For a package, we look up the instances available in the global info,     -- and then handle each instance in turn.+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =+      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal"+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =+      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal"+    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =+      error "Distribution.Client.Dependency.Modular.Builder: build.go called with Pkg goal"     go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) =       case M.lookup pn idx of         Nothing  -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn)@@ -135,6 +145,11 @@         reorder False = reverse         trivial = L.null t && L.null f +    -- For a stanza, we also create only two subtrees. The order is initially+    -- False, True. This can be changed later by constraints (force enabling+    -- the stanza by replacing the False branch with failure) or preferences+    -- (try enabling the stanza if possible by moving the True branch first).+     go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =       SChoiceF qsn gr trivial (P.fromList         [(False,                                                                  bs  { next = Goals }),@@ -165,4 +180,4 @@     topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]      qpns | ind       = makeIndependent igs-         | otherwise = L.map (Q None) igs+         | otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs view
@@ -1,4 +1,6 @@-module Distribution.Client.Dependency.Modular.Configured where+module Distribution.Client.Dependency.Modular.Configured+    ( CP(..)+    ) where  import Distribution.PackageDescription (FlagAssignment) -- from Cabal import Distribution.Client.Types (OptionalStanza)
cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view
@@ -1,8 +1,12 @@-module Distribution.Client.Dependency.Modular.ConfiguredConversion where+module Distribution.Client.Dependency.Modular.ConfiguredConversion+    ( convCP+    ) where  import Data.Maybe import Prelude hiding (pi) +import Distribution.Package (UnitId)+ import Distribution.Client.Types import Distribution.Client.Dependency.Types (ResolverPackage(..)) import qualified Distribution.Client.PackageIndex as CI@@ -13,23 +17,28 @@  import Distribution.Client.ComponentDeps (ComponentDeps) --convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage ->-          CP QPN -> ResolverPackage+-- | Converts from the solver specific result @CP QPN@ into+-- a 'ResolverPackage', which can then be converted into+-- the install plan.+convCP :: SI.InstalledPackageIndex ->+          CI.PackageIndex (SourcePackage loc) ->+          CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) =   case convPI qpi of     Left  pi -> PreExisting-                  (fromJust $ SI.lookupInstalledPackageId iidx pi)+                  (fromJust $ SI.lookupUnitId iidx pi)     Right pi -> Configured $ ConfiguredPackage-                  (fromJust $ CI.lookupPackageId sidx pi)+                  srcpkg                   fa                   es                   ds'+      where+        Just srcpkg = CI.lookupPackageId sidx pi   where     ds' :: ComponentDeps [ConfiguredId]     ds' = fmap (map convConfId) ds -convPI :: PI QPN -> Either InstalledPackageId PackageId+convPI :: PI QPN -> Either UnitId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi convPI qpi                    = Right $ confSrcId $ convConfId qpi @@ -42,4 +51,4 @@     sourceId    = PackageIdentifier pn v     installedId = case loc of                     Inst pi    -> pi-                    _otherwise -> fakeInstalledPackageId sourceId+                    _otherwise -> fakeUnitId sourceId
+ cabal/cabal-install/Distribution/Client/Dependency/Modular/Cycles.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+module Distribution.Client.Dependency.Modular.Cycles (+    detectCyclesPhase+  ) where++import Prelude hiding (cycle)+import Control.Monad+import Control.Monad.Reader+import Data.Graph (SCC)+import Data.Set   (Set)+import qualified Data.Graph       as Gr+import qualified Data.Map         as Map+import qualified Data.Set         as Set+import qualified Data.Traversable as T++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Distribution.Client.Dependency.Modular.Dependency+import Distribution.Client.Dependency.Modular.Flag+import Distribution.Client.Dependency.Modular.Package+import Distribution.Client.Dependency.Modular.Tree++type DetectCycles = Reader (ConflictSet QPN)++-- | Find and reject any solutions that are cyclic+detectCyclesPhase :: Tree QGoalReasonChain -> Tree QGoalReasonChain+detectCyclesPhase = (`runReader` Set.empty) .  cata go+  where+    -- Most cases are simple; we just need to remember which choices we made+    go :: TreeF QGoalReasonChain (DetectCycles (Tree QGoalReasonChain)) -> DetectCycles (Tree QGoalReasonChain)+    go (PChoiceF qpn gr     cs) = PChoice qpn gr     <$> local (extendConflictSet $ P qpn) (T.sequence cs)+    go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m <$> local (extendConflictSet $ F qfn) (T.sequence cs)+    go (SChoiceF qsn gr w   cs) = SChoice qsn gr w   <$> local (extendConflictSet $ S qsn) (T.sequence cs)+    go (GoalChoiceF         cs) = GoalChoice         <$>                                   (T.sequence cs)+    go (FailF cs reason)        = return $ Fail cs reason++    -- We check for cycles only if we have actually found a solution+    -- This minimizes the number of cycle checks we do as cycles are rare+    go (DoneF revDeps) = do+      fullSet <- ask+      return $ case findCycles fullSet revDeps of+        Nothing     -> Done revDeps+        Just relSet -> Fail relSet CyclicDependencies++-- | Given the reverse dependency map from a 'Done' node in the tree, as well+-- as the full conflict set containing all decisions that led to that 'Done'+-- node, check if the solution is cyclic. If it is, return the conflict set+-- containing all decisions that could potentially break the cycle.+findCycles :: ConflictSet QPN -> RevDepMap -> Maybe (ConflictSet QPN)+findCycles fullSet revDeps = do+    guard $ not (null cycles)+    return $ relevantConflictSet (Set.fromList (concat cycles)) fullSet+  where+    cycles :: [[QPN]]+    cycles = [vs | Gr.CyclicSCC vs <- scc]++    scc :: [SCC QPN]+    scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps++    aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])+    aux (fr, to) = (fr, fr, map snd to)++-- | Construct the relevant conflict set given the full conflict set that+-- lead to this decision and the set of packages involved in the cycle+relevantConflictSet :: Set QPN -> ConflictSet QPN -> ConflictSet QPN+relevantConflictSet cycle = Set.filter isRelevant+  where+    isRelevant :: Var QPN -> Bool+    isRelevant (P qpn)                  = qpn `Set.member` cycle+    isRelevant (F (FN (PI qpn _i) _fn)) = qpn `Set.member` cycle+    isRelevant (S (SN (PI qpn _i) _sn)) = qpn `Set.member` cycle
cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -4,20 +4,16 @@     -- * Variables     Var(..)   , simplifyVar-  , showVar   , varPI     -- * Conflict sets   , ConflictSet   , showCS     -- * Constrained instances   , CI(..)-  , showCI   , merge     -- * Flagged dependencies   , FlaggedDeps   , FlaggedDep(..)-  , TrueFlaggedDeps-  , FalseFlaggedDeps   , Dep(..)   , showDep   , flattenFlaggedDeps@@ -26,39 +22,32 @@     -- ** Setting/forgetting components   , forgetCompOpenGoal   , setCompFlaggedDeps-    -- ** Selecting subsets-  , nonSetupDeps-  , setupDeps-  , select     -- * Reverse dependency map   , RevDepMap     -- * Goals   , Goal(..)   , GoalReason(..)-  , GoalReasonChain   , QGoalReasonChain   , ResetGoal(..)   , toConflictSet-  , goalReasonToVars-  , goalReasonChainToVars-  , goalReasonChainsToVars+  , extendConflictSet     -- * Open goals   , OpenGoal(..)   , close-    -- * Version ranges pairsed with origins (goals)-  , VROrigin-  , collapse   ) where  import Prelude hiding (pi)  import Data.List (intercalate) import Data.Map (Map)-import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.List as L import qualified Data.Set  as S +import Language.Haskell.Extension (Extension(..), Language(..))++import Distribution.Text+ import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Package import Distribution.Client.Dependency.Modular.Version@@ -180,10 +169,15 @@ -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. data FlaggedDep comp qpn =+    -- | Dependencies which are conditional on a flag choice.     Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+    -- | Dependencies which are conditional on whether or not a stanza+    -- (e.g., a test suite or benchmark) is enabled.   | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)+    -- | Dependencies for which are always enabled, for the component+    -- 'comp' (or requested for the user, if comp is @()@).   | Simple (Dep qpn) comp-  deriving (Eq, Show, Functor)+  deriving (Eq, Show)  -- | Conversatively flatten out flagged dependencies --@@ -201,8 +195,16 @@  -- | A dependency (constraint) associates a package name with a -- constrained instance.-data Dep qpn = Dep qpn (CI qpn)-  deriving (Eq, Show, Functor)+--+-- 'Dep' intentionally has no 'Functor' instance because the type variable+-- is used both to record the dependencies as well as who's doing the+-- depending; having a 'Functor' instance makes bugs where we don't distinguish+-- these two far too likely. (By rights 'Dep' ought to have two type variables.)+data Dep qpn = Dep  qpn (CI qpn)  -- dependency on a package+             | Ext  Extension     -- dependency on a language extension+             | Lang Language      -- dependency on a language version+             | Pkg  PN VR         -- dependency on a pkg-config package+  deriving (Eq, Show)  showDep :: Dep QPN -> String showDep (Dep qpn (Fixed i (Goal v _))          ) =@@ -212,6 +214,11 @@   showVar v ++ " => " ++ showQPN qpn ++ showVR vr showDep (Dep qpn ci                            ) =   showQPN qpn ++ showCI ci+showDep (Ext ext)   = "requires " ++ display ext+showDep (Lang lang) = "requires " ++ display lang+showDep (Pkg pn vr) = "requires pkg-config package "+                      ++ display pn ++ display vr+                      ++ ", not found in the pkg-config database"  -- | Options for goal qualification (used in 'qualifyDeps') --@@ -230,12 +237,8 @@ -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN-qualifyDeps QO{..} (Q pp' pn) = go+qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go   where-    -- The Base qualifier does not get inherited-    pp :: PP-    pp = (if qoBaseShim then stripBase else id) pp'-     go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN     go = map go1 @@ -244,17 +247,41 @@     go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)     go1 (Simple dep comp)    = Simple (goD dep comp) comp +    -- Suppose package B has a setup dependency on package A.+    -- This will be recorded as something like+    --+    -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason])+    --+    -- Observe that when we qualify this dependency, we need to turn that+    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier+    -- to the goal or the goal reason chain.     goD :: Dep PN -> Component -> Dep QPN-    goD dep comp-      | qBase  dep  = fmap (Q (Base  pn pp)) dep-      | qSetup comp = fmap (Q (Setup pn pp)) dep-      | otherwise   = fmap (Q           pp ) dep+    goD (Ext  ext)    _    = Ext  ext+    goD (Lang lang)   _    = Lang lang+    goD (Pkg pkn vr)  _    = Pkg pkn vr+    goD (Dep  dep ci) comp+      | qBase  dep  = Dep (Q (PP ns (Base  pn)) dep) (fmap (Q pp) ci)+      | qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci)+      | otherwise   = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci) +    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then+    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup+    -- dependency on R. We do not do this for the base qualifier however.+    --+    -- The inherited qualifier is only used for regular dependencies; for setup+    -- and base deppendencies we override the existing qualifier. See #3160 for+    -- a detailed discussion.+    inheritedQ :: Qualifier+    inheritedQ = case q of+                   Setup _     -> q+                   Unqualified -> q+                   Base _      -> Unqualified+     -- Should we qualify this goal with the 'Base' package path?-    qBase :: Dep PN -> Bool-    qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base"+    qBase :: PN -> Bool+    qBase dep = qoBaseShim && unPackageName dep == "base" -    -- Should we qualify this goal with the 'Setup' packaeg path?+    -- Should we qualify this goal with the 'Setup' package path?     qSetup :: Component -> Bool     qSetup comp = qoSetupIndependent && comp == ComponentSetup @@ -288,60 +315,6 @@ mapCompFlaggedDep g (Simple  pn a      ) = Simple  pn (g a)  {--------------------------------------------------------------------------------  Selecting FlaggedDeps subsets--  (Correspond to the functions with the same names in ComponentDeps).--------------------------------------------------------------------------------}--nonSetupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a-nonSetupDeps = select (/= ComponentSetup)--setupDeps :: FlaggedDeps Component a -> FlaggedDeps Component a-setupDeps = select (== ComponentSetup)---- | Select the dependencies of a given component------ The modular solver kind of flattens the dependency trees from the .cabal--- file, putting the component of each dependency at the leaves, rather than--- indexing per component. For instance, package C might have flagged deps that--- look something like------ > Flagged <flagName> ..--- >   [Simple <package A> ComponentLib]--- >   [Simple <package B> ComponentLib]------ indicating that the library component of C relies on either A or B, depending--- on the flag. This makes it somewhat awkward however to extract certain kinds--- of dependencies. In particular, extracting, say, the setup dependencies from--- the above set of dependencies could either return the empty list, or else------ > Flagged <flagName> ..--- >   []--- >   []------ Both answers are reasonable; we opt to return the empty list in this--- case, as it results in simpler search trees in the builder.------ (Note that the builder already introduces separate goals for all flags of a--- package, independently of whether or not they are used in any component, so--- we don't have to worry about preserving flags here.)-select :: (Component -> Bool) -> FlaggedDeps Component a -> FlaggedDeps Component a-select p = mapMaybe go-  where-    go :: FlaggedDep Component a -> Maybe (FlaggedDep Component a)-    go (Flagged fn nfo  t f) = let t' = mapMaybe go t-                                   f' = mapMaybe go f-                               in if null t' && null f'-                                     then Nothing-                                     else Just $ Flagged fn nfo t' f'-    go (Stanza  sn      t  ) = let t' = mapMaybe go t-                               in if null t'-                                     then Nothing-                                     else Just $ Stanza  sn     t'-    go (Simple  pn comp    ) = if p comp then Just $ Simple pn comp-                                         else Nothing--{-------------------------------------------------------------------------------   Reverse dependency map -------------------------------------------------------------------------------} @@ -381,15 +354,22 @@  instance ResetGoal Dep where   resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)+  resetGoal _ (Ext ext)    = Ext ext+  resetGoal _ (Lang lang)  = Lang lang+  resetGoal _ (Pkg pn vr)  = Pkg pn vr  instance ResetGoal Goal where   resetGoal = const --- | Compute a conflic set from a goal. The conflict set contains the--- closure of goal reasons as well as the variable of the goal itself.+-- | Compute a conflict set from a goal. The conflict set contains the closure+-- of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs) +-- | Add another variable into a conflict set+extendConflictSet :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn+extendConflictSet = S.insert . simplifyVar+ goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal                 = S.empty goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)@@ -399,9 +379,6 @@ goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn goalReasonChainToVars = S.unions . L.map goalReasonToVars -goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn-goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars- {-------------------------------------------------------------------------------   Open goals -------------------------------------------------------------------------------}@@ -415,6 +392,12 @@ -- need only during the build phase. close :: OpenGoal comp -> Goal QPN close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr+close (OpenGoal (Simple (Ext     _) _) _ ) =+  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal"+close (OpenGoal (Simple (Lang    _) _) _ ) =+  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal"+close (OpenGoal (Simple (Pkg   _ _) _) _ ) =+  error "Distribution.Client.Dependency.Modular.Dependency.close: called on Pkg goal" close (OpenGoal (Flagged qfn _ _ _ )   gr) = Goal (F qfn) gr close (OpenGoal (Stanza  qsn _)        gr) = Goal (S qsn) gr @@ -427,4 +410,4 @@ -- | Helper function to collapse a list of version ranges with origins into -- a single, simplified, version range. collapse :: [VROrigin qpn] -> VR-collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst+collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR
cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs view
@@ -1,8 +1,9 @@-module Distribution.Client.Dependency.Modular.Explore where+module Distribution.Client.Dependency.Modular.Explore+    ( backjump+    , backjumpAndExplore+    ) where -import Control.Applicative as A-import Data.Foldable-import Data.List as L+import Data.Foldable as F import Data.Map as M import Data.Set as S @@ -11,139 +12,77 @@ import Distribution.Client.Dependency.Modular.Log import Distribution.Client.Dependency.Modular.Message import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree---- | Backjumping.------ A tree traversal that tries to propagate conflict sets--- up the tree from the leaves, and thereby cut branches.--- All the tricky things are done in the function 'combine'.-backjump :: Tree a -> Tree (Maybe (ConflictSet QPN))-backjump = snd . cata go-  where-    go (FailF c fr) = (Just c, Fail c fr)-    go (DoneF rdm ) = (Nothing, Done rdm)-    go (PChoiceF qpn _     ts) = (c, PChoice qpn c     (P.fromList ts'))-      where-        ~(c, ts') = combine (P qpn) (P.toList ts) S.empty-    go (FChoiceF qfn _ b m ts) = (c, FChoice qfn c b m (P.fromList ts'))-      where-        ~(c, ts') = combine (F qfn) (P.toList ts) S.empty-    go (SChoiceF qsn _ b   ts) = (c, SChoice qsn c b   (P.fromList ts'))-      where-        ~(c, ts') = combine (S qsn) (P.toList ts) S.empty-    go (GoalChoiceF        ts) = (c, GoalChoice        (P.fromList ts'))-      where-        ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts-        c          = case cs of []    -> Nothing-                                d : _ -> d+import qualified Distribution.Client.Dependency.Types as T --- | The 'combine' function is at the heart of backjumping. It takes--- the variable we're currently considering, and a list of children--- annotated with their respective conflict sets, and an accumulator--- for the result conflict set. It returns a combined conflict set--- for the parent node, and a (potentially shortened) list of children--- with the annotations removed.------ It is *essential* that we produce the results as early as possible.--- In particular, we have to produce the list of children prior to--- traversing the entire list -- otherwise we lose the desired behaviour--- of being able to traverse the tree from left to right incrementally.+-- | This function takes the variable we're currently considering and a+-- list of children's logs. Each log yields either a solution or a+-- conflict set. The result is a combined log for the parent node that+-- has explored a prefix of the children. ----- We can shorten the list of children if we find an individual conflict--- set that does not contain the current variable. In this case, we can--- just lift the conflict set to the current level, because the current--- level cannot possibly have contributed to this conflict, so no other--- choice at the current level would avoid the conflict.+-- We can stop traversing the children's logs if we find an individual+-- conflict set that does not contain the current variable. In this+-- case, we can just lift the conflict set to the current level,+-- because the current level cannot possibly have contributed to this+-- conflict, so no other choice at the current level would avoid the+-- conflict. ----- If any of the children might contain a successful solution--- (indicated by Nothing), then Nothing will be the combined--- conflict set. If all children contain conflict sets, we can+-- If any of the children might contain a successful solution, we can+-- return it immediately. If all children contain conflict sets, we can -- take the union as the combined conflict set.-combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] ->-           ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)])-combine _   []                      c = (Just c, [])-combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $-                                        case d of-                                          Just e | not (simplifyVar var `S.member` e) -> (Just e, [])-                                                 | otherwise                          -> combine var xs (e `S.union` c)-                                          Nothing                                     -> (Nothing, snd $ combine var xs S.empty)---- | Naive backtracking exploration of the search tree. This will yield correct--- assignments only once the tree itself is validated.-explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap))-explore = cata go+backjump :: F.Foldable t => Var QPN -> t (ConflictSetLog a) -> ConflictSetLog a+backjump var xs = F.foldr combine logBackjump xs S.empty   where-    go (FailF _ _)           _           = A.empty-    go (DoneF rdm)           a           = pure (a, rdm)-    go (PChoiceF qpn _     ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ (POption k _) r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice-      ts-    go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa (M.insert qfn k fa) sa)) -- record the flag choice-      ts-    go (SChoiceF qsn _ _   ts) (A pa fa sa)   =-      asum $                                      -- try children in order,-      P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa fa (M.insert qsn k sa))) -- record the flag choice-      ts-    go (GoalChoiceF        ts) a              =-      casePSQ ts A.empty                      -- empty goal choice is an internal error-        (\ _k v _xs -> v a)                   -- commit to the first goal choice+    combine :: ConflictSetLog a+            -> (ConflictSet QPN -> ConflictSetLog a)+            ->  ConflictSet QPN -> ConflictSetLog a+    combine (T.Done x)    _ _               = T.Done x+    combine (T.Fail cs)   f csAcc+      | not (simplifyVar var `S.member` cs) = logBackjump cs+      | otherwise                           = f (csAcc `S.union` cs)+    combine (T.Step m ms) f cs              = T.Step m (combine ms f cs) --- | Version of 'explore' that returns a 'Log'.-exploreLog :: Tree (Maybe (ConflictSet QPN)) ->-              (Assignment -> Log Message (Assignment, RevDepMap))+    logBackjump :: ConflictSet QPN -> ConflictSetLog a+    logBackjump cs = failWith (Failure cs Backjump) cs++type ConflictSetLog = T.Progress Message (ConflictSet QPN)++-- | A tree traversal that simultaneously propagates conflict sets up+-- the tree from the leaves and creates a log.+exploreLog :: Tree a -> (Assignment -> ConflictSetLog (Assignment, RevDepMap)) exploreLog = cata go   where-    go (FailF c fr)          _           = failWith (Failure c fr)+    go :: TreeF a (Assignment -> ConflictSetLog (Assignment, RevDepMap))+               -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))+    go (FailF c fr)          _           = failWith (Failure c fr) c     go (DoneF rdm)           a           = succeedWith Success (a, rdm)-    go (PChoiceF qpn c     ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    go (PChoiceF qpn _     ts) (A pa fa sa)   =+      backjump (P qpn) $                          -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ i@(POption k _) r -> tryWith (TryP qpn i) $     -- log and ...+        (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...                     r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice       ts-    go (FChoiceF qfn c _ _ ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =+      backjump (F qfn) $                          -- try children in order,       P.mapWithKey                                -- when descending ...         (\ k r -> tryWith (TryF qfn k) $          -- log and ...                     r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice       ts-    go (SChoiceF qsn c _   ts) (A pa fa sa)   =-      backjumpInfo c $-      asum $                                      -- try children in order,+    go (SChoiceF qsn _ _   ts) (A pa fa sa)   =+      backjump (S qsn) $                          -- try children in order,       P.mapWithKey                                -- when descending ...         (\ k r -> tryWith (TryS qsn k) $          -- log and ...                     r (A pa fa (M.insert qsn k sa))) -- record the pkg choice       ts     go (GoalChoiceF        ts) a           =-      casePSQ ts-        (failWith (Failure S.empty EmptyGoalChoice))   -- empty goal choice is an internal error-        (\ k v _xs -> continueWith (Next (close k)) (v a))     -- commit to the first goal choice---- | Add in information about pruned trees.------ TODO: This isn't quite optimal, because we do not merely report the shape of the--- tree, but rather make assumptions about where that shape originated from. It'd be--- better if the pruning itself would leave information that we could pick up at this--- point.-backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a-backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'!-                           Nothing -> A.empty-                           Just cs -> failWith (Failure cs Backjump)---- | Interface.-exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap)-exploreTree t = explore t (A M.empty M.empty M.empty)+      P.casePSQ ts+        (failWith (Failure S.empty EmptyGoalChoice) S.empty) -- empty goal choice is an internal error+        (\ k v _xs -> continueWith (Next (close k)) (v a))   -- commit to the first goal choice  -- | Interface.-exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap)-exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty)+backjumpAndExplore :: Tree a -> Log Message (Assignment, RevDepMap)+backjumpAndExplore t = toLog $ exploreLog t (A M.empty M.empty M.empty)+  where+    toLog :: T.Progress step fail done -> Log step done+    toLog = T.foldProgress T.Step (const (T.Fail ())) T.Done
cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs view
@@ -1,5 +1,19 @@ {-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.Dependency.Modular.Flag where+module Distribution.Client.Dependency.Modular.Flag+    ( FInfo(..)+    , Flag+    , FlagInfo+    , FN(..)+    , QFN+    , QSN+    , SN(..)+    , mkFlag+    , showFBool+    , showQFN+    , showQFNBool+    , showQSN+    , showQSNBool+    ) where  import Data.Map as M import Prelude hiding (pi)@@ -12,10 +26,6 @@ -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN (PI qpn) Flag   deriving (Eq, Ord, Show, Functor)---- | Extract the package name from a flag name.-getPN :: FN qpn -> qpn-getPN (FN (PI qpn _) _) = qpn  -- | Flag identifier. Just a string. type Flag = FlagName
cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs view
@@ -1,4 +1,9 @@-module Distribution.Client.Dependency.Modular.Index where+module Distribution.Client.Dependency.Modular.Index+    ( Index+    , PInfo(..)+    , defaultQualifyOptions+    , mkIndex+    ) where  import Data.List as L import Data.Map as M
cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -1,14 +1,12 @@-module Distribution.Client.Dependency.Modular.IndexConversion (-    convPIs-    -- * TODO: The following don't actually seem to be used anywhere?-  , convIPI-  , convSPI-  , convPI-  ) where+module Distribution.Client.Dependency.Modular.IndexConversion+    ( convPIs+    ) where  import Data.List as L import Data.Map as M import Data.Maybe+import Data.Monoid as Mon+import Data.Set as S import Prelude hiding (pi)  import qualified Distribution.Client.PackageIndex as CI@@ -18,6 +16,7 @@ import Distribution.InstalledPackageInfo as IPI import Distribution.Package                          -- from Cabal import Distribution.PackageDescription as PD         -- from Cabal+import Distribution.PackageDescription.Configuration as PDC import qualified Distribution.Simple.PackageIndex as SI import Distribution.System @@ -40,7 +39,7 @@ -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. convPIs :: OS -> Arch -> CompilerInfo -> Bool -> Bool ->-           SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> Index+           SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index convPIs os arch comp sip strfl iidx sidx =   mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sidx) @@ -59,21 +58,18 @@     shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed))     shadow x                                = x -convIPI :: Bool -> SI.InstalledPackageIndex -> Index-convIPI sip = mkIndex . convIPI' sip- -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi =-  let ipid = IPI.installedPackageId ipi-      i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)-      pn = pkgName (sourcePackageId ipi)-  in  case mapM (convIPId pn idx) (IPI.depends ipi) of+  case mapM (convIPId pn idx) (IPI.depends ipi) of         Nothing  -> (pn, i, PInfo []            M.empty (Just Broken))         Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing)  where   -- We assume that all dependencies of installed packages are _library_ deps-  setComp = setCompFlaggedDeps ComponentLib+  ipid = IPI.installedUnitId ipi+  i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)+  pn = pkgName (sourcePackageId ipi)+  setComp = setCompFlaggedDeps (ComponentLib (unPackageName pn)) -- TODO: Installed packages should also store their encapsulations!  -- | Convert dependencies specified by an installed package id into@@ -82,9 +78,9 @@ -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored.-convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep () PN)+convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) convIPId pn' idx ipid =-  case SI.lookupInstalledPackageId idx ipid of+  case SI.lookupUnitId idx ipid of     Nothing  -> Nothing     Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)                     pn = pkgName (sourcePackageId ipi)@@ -93,15 +89,11 @@ -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. convSPI' :: OS -> Arch -> CompilerInfo -> Bool ->-            CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]+            CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages -convSPI :: OS -> Arch -> CompilerInfo -> Bool ->-           CI.PackageIndex SourcePackage -> Index-convSPI os arch cinfo strfl = mkIndex . convSPI' os arch cinfo strfl- -- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage -> (PN, I, PInfo)+convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage loc -> (PN, I, PInfo) convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =   let i = I pv InRepo   in  (pn, i, convGPD os arch cinfo strfl (PI pn i) gpd)@@ -113,24 +105,84 @@ -- | Convert a generic package description to a solver-specific 'PInfo'. convGPD :: OS -> Arch -> CompilerInfo -> Bool ->            PI PN -> GenericPackageDescription -> PInfo-convGPD os arch comp strfl pi+convGPD os arch cinfo strfl pi@(PI pn _)         (GenericPackageDescription pkg flags libs exes tests benchs) =   let     fds  = flagInfo strfl flags-    conv = convCondTree os arch comp pi fds (const True)++    -- | We have to be careful to filter out dependencies on+    -- internal libraries, since they don't refer to real packages+    -- and thus cannot actually be solved over.  We'll do this+    -- by creating a set of package names which are "internal"+    -- and dropping them as we convert.+    ipns = S.fromList [ PackageName nm+                      | (nm, _) <- libs+                      -- Don't include the true package name;+                      -- qualification could make this relevant.+                      -- TODO: Can we qualify over internal+                      -- dependencies? Not for now!+                      , PackageName nm /= pn ]++    conv :: Mon.Monoid a => Component -> (a -> BuildInfo) ->+            CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN+    conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo ipns .+                        PDC.addBuildableCondition getInfo++    flagged_deps+        = concatMap (\(nm, ds) -> conv (ComponentLib nm)   libBuildInfo       ds) libs+       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)   buildInfo          ds) exes+       ++ prefix (Stanza (SN pi TestStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentTest nm)  testBuildInfo      ds) tests)+       ++ prefix (Stanza (SN pi BenchStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs)+       ++ maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)+   in-    PInfo-      (maybe []    (conv ComponentLib                       ) libs    ++-       maybe []    (convSetupBuildInfo pi)    (setupBuildInfo pkg)    ++-       concatMap   (\(nm, ds) -> conv (ComponentExe nm)   ds) exes    ++-      prefix (Stanza (SN pi TestStanzas))-        (L.map     (\(nm, ds) -> conv (ComponentTest nm)  ds) tests)  ++-      prefix (Stanza (SN pi BenchStanzas))-        (L.map     (\(nm, ds) -> conv (ComponentBench nm) ds) benchs))-      fds-      Nothing+    PInfo flagged_deps fds Nothing -prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn+-- With convenience libraries, we have to do some work.  Imagine you+-- have the following Cabal file:+--+--      name: foo+--      library foo-internal+--          build-depends: external-a+--      library+--          build-depends: foo-internal, external-b+--      library foo-helper+--          build-depends: foo, external-c+--      test-suite foo-tests+--          build-depends: foo-helper, external-d+--+-- What should the final flagged dependency tree be?  Ideally, it+-- should look like this:+--+--      [ Simple (Dep external-a) (Library foo-internal)+--      , Simple (Dep external-b) (Library foo)+--      , Stanza (SN foo TestStanzas) $+--          [ Simple (Dep external-c) (Library foo-helper)+--          , Simple (Dep external-d) (TestSuite foo-tests) ]+--      ]+--+-- There are two things to note:+--+--      1. First, we eliminated the "local" dependencies foo-internal+--      and foo-helper.  This are implicitly assumed to refer to "foo"+--      so we don't need to have them around.  If you forget this,+--      Cabal will then try to pick a version for "foo-helper" but+--      no such package exists (this is the cost of overloading+--      build-depends to refer to both packages and components.)+--+--      2. Second, it is more precise to have external-c be qualified+--      by a test stanza, since foo-helper only needs to be built if+--      your are building the test suite (and not the main library).+--      If you omit it, Cabal will always attempt to depsolve for+--      foo-helper even if you aren't building the test suite.++-- | Create a flagged dependency tree from a list @fds@ of flagged+-- dependencies, using @f@ to form the tree node (@f@ will be+-- something like @Stanza sn@).+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn)+       -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn prefix _ []  = [] prefix f fds = [f (concat fds)] @@ -139,17 +191,37 @@ flagInfo :: Bool -> [PD.Flag] -> FlagInfo flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m)))) --- | Convert condition trees to flagged dependencies.+-- | Internal package names, which should not be interpreted as true+-- dependencies.+type IPNs = Set PN++-- | Convenience function to delete a 'FlaggedDep' if it's+-- for a 'PN' that isn't actually real.+filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN+filterIPNs ipns (Dependency pn _) fd+    | S.notMember pn ipns = [fd]+    | otherwise           = []++-- | Convert condition trees to flagged dependencies.  Mutually+-- recursive with 'convBranch'.  See 'convBranch' for an explanation+-- of all arguments preceeding the input 'CondTree'. convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->-                (a -> Bool) -> -- how to detect if a branch is active                 Component ->+                (a -> BuildInfo) ->+                IPNs ->                 CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN-convCondTree os arch cinfo pi@(PI pn _) fds p comp (CondNode info ds branches)-  | p info    = L.map (\d -> D.Simple (convDep pn d) comp) ds  -- unconditional dependencies-              ++ concatMap (convBranch os arch cinfo pi fds p comp) branches-  | otherwise = []+convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo ipns (CondNode info ds branches) =+                 concatMap+                    (\d -> filterIPNs ipns d (D.Simple (convDep pn d) comp))+                    ds  -- unconditional package dependencies+              ++ L.map (\e -> D.Simple (Ext  e) comp) (PD.allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch os arch cinfo pi fds comp getInfo ipns) branches+  where+    bi = getInfo info --- | Branch interpreter.+-- | Branch interpreter.  Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the -- solver's flagged dependency format, which is weaker. Condition trees can@@ -157,16 +229,40 @@ -- flags (such as architecture, or compiler flavour). We try to evaluate the -- special flags and subsequently simplify to a tree that only depends on -- simple flag choices.+--+-- This function takes a number of arguments:+--+--      1. Some pre dependency-solving known information ('OS', 'Arch',+--         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,+--+--      2. The package instance @'PI' 'PN'@ which this condition tree+--         came from, so that we can correctly associate @flag()@+--         variables with the correct package name qualifier,+--+--      3. The flag defaults 'FlagInfo' so that we can populate+--         'Flagged' dependencies with 'FInfo',+--+--      4. The name of the component 'Component' so we can record where+--         the fine-grained information about where the component came+--         from (see 'convCondTree'), and+--+--      5. A selector to extract the 'BuildInfo' from the leaves of+--         the 'CondTree' (which actually contains the needed+--         dependency information.)+--+--      6. The set of package names which should be considered internal+--         dependencies, and thus not handled as dependencies. convBranch :: OS -> Arch -> CompilerInfo ->               PI PN -> FlagInfo ->-              (a -> Bool) -> -- how to detect if a branch is active               Component ->+              (a -> BuildInfo) ->+              IPNs ->               (Condition ConfVar,                CondTree ConfVar [Dependency] a,                Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN-convBranch os arch cinfo pi fds p comp (c', t', mf') =-  go c' (          convCondTree os arch cinfo pi fds p comp   t')-        (maybe [] (convCondTree os arch cinfo pi fds p comp) mf')+convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns (c', t', mf') =+  go c' (          convCondTree os arch cinfo pi fds comp getInfo ipns   t')+        (maybe [] (convCondTree os arch cinfo pi fds comp getInfo ipns) mf')   where     go :: Condition ConfVar ->           FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN@@ -198,20 +294,21 @@     -- with deferring flag choices will then usually first resolve this package,     -- and try an already installed version before imposing a default flag choice     -- that might not be what we want.+    --+    -- Note that we make assumptions here on the form of the dependencies that+    -- can occur at this point. In particular, no occurrences of Fixed, and no+    -- occurrences of multiple version ranges, as all dependencies below this+    -- point have been generated using 'convDep'.     extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN-    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) comp-                           | D.Simple (Dep pn  _) _ <- ps-                           , D.Simple (Dep pn' _) _ <- ps'-                           , pn == pn'+    extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, Goal (P pn) [])])) comp+                           | D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps+                           , D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps'+                           , pn1 == pn2                            ]  -- | Convert a Cabal dependency to a solver-specific dependency. convDep :: PN -> Dependency -> Dep PN convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])])---- | Convert a Cabal package identifier to a solver-specific dependency.-convPI :: PN -> PackageIdentifier -> Dep PN-convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])])  -- | Convert setup dependencies convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN
cabal/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs view
@@ -274,6 +274,12 @@           lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs       lg'' <- lift' $ lgMerge parents lg lg'       updateLinkGroup lg''+    -- For extensions and language dependencies, there is nothing to do.+    -- No choice is involved, just checking, so there is nothing to link.+    go (Simple (Ext  _)             _) = return ()+    go (Simple (Lang _)             _) = return ()+    -- Similarly for pkg-config constraints+    go (Simple (Pkg  _ _)           _) = return ()     go (Flagged fn _ t f) = do       vs <- get       case M.lookup fn (vsFlags vs) of
cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs view
@@ -1,7 +1,15 @@-module Distribution.Client.Dependency.Modular.Log where+module Distribution.Client.Dependency.Modular.Log+    ( Log+    , continueWith+    , failWith+    , logToProgress+    , succeedWith+    , tryWith+    ) where  import Control.Applicative import Data.List as L+import Data.Maybe (isNothing) import Data.Set as S  import Distribution.Client.Dependency.Types -- from Cabal@@ -18,107 +26,81 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m () a --- | Turns a log into a list of messages paired with a final result. A final result--- of 'Nothing' indicates failure. A final result of 'Just' indicates success.--- Keep in mind that forcing the second component of the returned pair will force the--- entire log.-runLog :: Log m a -> ([m], Maybe a)-runLog (Done x)       = ([], Just x)-runLog (Fail _)       = ([], Nothing)-runLog (Step m p)     = let-                          (ms, r) = runLog p-                        in-                          (m : ms, r)+messages :: Progress step fail done -> [step]+messages = foldProgress (:) (const []) (const [])  -- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. -- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the -- limit is 'Just 0', backtracking is completely disabled. logToProgress :: Maybe Int -> Log Message a -> Progress String String a logToProgress mbj l = let-                        (ms, s) = runLog l-                        -- 'Nothing' for 's' means search tree exhaustively searched and failed-                        (es, e) = proc 0 ms -- catch first error (always)-                        -- 'Nothing' in 'e' means no backjump found-                        (ns, t) = case mbj of-                                     Nothing -> (ms, Nothing)-                                     Just n  -> proc n ms-                        -- 'Nothing' in 't' means backjump limit not reached-                        -- prefer first error over later error-                        (exh, r) = case t of-                                     -- backjump limit not reached-                                     Nothing -> case s of-                                                  Nothing -> (True, e) -- failed after exhaustive search-                                                  Just _  -> (True, Nothing) -- success-                                     -- backjump limit reached; prefer first error-                                     Just _  -> (False, e) -- failed after backjump limit was reached+                        es = proc (Just 0) l -- catch first error (always)+                        ms = useFirstError (proc mbj l)                       in go es es -- trace for first error-                            (showMessages (const True) True ns) -- shortened run-                            r s exh-  where-    -- Proc takes the allowed number of backjumps and a list of messages and explores the-    -- message list until the maximum number of backjumps has been reached. The log until-    -- that point as well as whether we have encountered an error or not are returned.-    proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))-    proc _ []                             = ([], Nothing)-    proc n (   Failure cs Backjump  : xs@(Leave : Failure cs' Backjump : _))-      | cs == cs'                         = proc n xs -- repeated backjumps count as one-    proc 0 (   Failure cs Backjump  : _ ) = ([], Just cs)-    proc n (x@(Failure _  Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)-    proc n (x                       : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc  n      xs)--    -- This function takes a lot of arguments. The first two are both supposed to be-    -- the log up to the first error. That's the error that will always be printed in-    -- case we do not find a solution. We pass this log twice, because we evaluate it-    -- in parallel with the full log, but we also want to retain the reference to its-    -- beginning for when we print it. This trick prevents a space leak!-    ---    -- The third argument is the full log, the fifth and six error conditions.-    -- The seventh argument indicates whether the search was exhaustive.-    ---    -- The order of arguments is important! In particular 's' must not be evaluated-    -- unless absolutely necessary. It contains the final result, and if we shortcut-    -- with an error due to backjumping, evaluating 's' would still require traversing-    -- the entire tree.-    go ms (_ : ns) (x : xs) r         s        exh = Step x (go ms ns xs r s exh)-    go ms []       (x : xs) r         s        exh = Step x (go ms [] xs r s exh)-    go ms _        []       (Just cs) _        exh = Fail $-                                                     "Could not resolve dependencies:\n" ++-                                                     unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++-                                                     (if exh then "Dependency tree exhaustively searched.\n"-                                                             else "Backjump limit reached (" ++ currlimit mbj ++-                                                                      "change with --max-backjumps or try to run with --reorder-goals).\n")-                                                         where currlimit (Just n) = "currently " ++ show n ++ ", "-                                                               currlimit Nothing  = ""-    go _  _        []       _         (Just s) _   = Done s-    go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen--logToProgress' :: Log Message a -> Progress String String a-logToProgress' l = let-                    (ms, r) = runLog l-                    xs      = showMessages (const True) True ms-                  in go xs r+                            (showMessages (const True) True ms) -- run with backjump limit applied   where-    go [x]    Nothing  = Fail x-    go []     Nothing  = Fail ""-    go []     (Just r) = Done r-    go (x:xs) r        = Step x (go xs r)+    -- Proc takes the allowed number of backjumps and a 'Progress' and explores the+    -- messages until the maximum number of backjumps has been reached. It filters out+    -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates+    -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the+    -- original success result or replaces the original failure with 'Nothing'.+    proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b+    proc _        (Done x)                          = Done x+    proc _        (Fail _)                          = Fail Nothing+    proc mbj'     (Step   (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))+      | cs == cs'                                   = proc mbj' xs -- repeated backjumps count as one+    proc (Just 0) (Step   (Failure cs Backjump)  _) = Fail (Just cs)+    proc (Just n) (Step x@(Failure _  Backjump) xs) = Step x (proc (Just (n - 1)) xs)+    proc mbj'     (Step x                       xs) = Step x (proc mbj'           xs) +    -- Sets the conflict set from the first backjump as the final error, and records+    -- whether the search was exhaustive.+    useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b+                  -> Progress Message (Bool, Maybe (ConflictSet QPN)) b+    useFirstError = replace Nothing+      where+        replace _       (Done x)                          = Done x+        replace cs'     (Fail cs)                         = -- 'Nothing' means backjump limit not reached.+                                                            -- Prefer first error over later error.+                                                            Fail (isNothing cs, cs' <|> cs)+        replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs+        replace cs'     (Step x                       xs) = Step x $ replace cs' xs -runLogIO :: Log Message a -> IO (Maybe a)-runLogIO x =-  do-    let (ms, r) = runLog x-    putStr (unlines $ showMessages (const True) True ms)-    return r+    -- The first two arguments are both supposed to be the log up to the first error.+    -- That's the error that will always be printed in case we do not find a solution.+    -- We pass this log twice, because we evaluate it in parallel with the full log,+    -- but we also want to retain the reference to its beginning for when we print it.+    -- This trick prevents a space leak!+    --+    -- The third argument is the full log, ending with either the solution or the+    -- exhaustiveness and first conflict set.+    go :: Progress Message a b+       -> Progress Message a b+       -> Progress String (Bool, Maybe (ConflictSet QPN)) b+       -> Progress String String b+    go ms (Step _ ns) (Step x xs)           = Step x (go ms ns xs)+    go ms r           (Step x xs)           = Step x (go ms r  xs)+    go ms _           (Fail (exh, Just cs)) = Fail $+                                              "Could not resolve dependencies:\n" +++                                              unlines (messages $ showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) +++                                              (if exh then "Dependency tree exhaustively searched.\n"+                                                      else "Backjump limit reached (" ++ currlimit mbj +++                                                               "change with --max-backjumps or try to run with --reorder-goals).\n")+                                                  where currlimit (Just n) = "currently " ++ show n ++ ", "+                                                        currlimit Nothing  = ""+    go _  _           (Done s)              = Done s+    go _  _           (Fail (_, Nothing))   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen -failWith :: m -> Log m a-failWith m = Step m (Fail ())+failWith :: step -> fail -> Progress step fail done+failWith s f = Step s (Fail f) -succeedWith :: m -> a -> Log m a-succeedWith m x = Step m (Done x)+succeedWith :: step -> done -> Progress step fail done+succeedWith s d = Step s (Done d) -continueWith :: m -> Log m a -> Log m a+continueWith :: step -> Progress step fail done -> Progress step fail done continueWith = Step -tryWith :: Message -> Log Message a -> Log Message a-tryWith m x = Step m (Step Enter x) <|> failWith Leave+tryWith :: Message+        -> Progress Message fail done+        -> Progress Message fail done+tryWith m = Step m . Step Enter . foldProgress Step (failWith Leave) Done
cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+ module Distribution.Client.Dependency.Modular.Message (     Message(..),     showMessages@@ -12,8 +14,9 @@ import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Package import Distribution.Client.Dependency.Modular.Tree+         ( FailReason(..), POption(..) ) import Distribution.Client.Dependency.Types-         ( ConstraintSource(..), showConstraintSource )+         ( ConstraintSource(..), showConstraintSource, Progress(..) )  data Message =     Enter           -- ^ increase indentation level@@ -37,41 +40,73 @@ -- The second argument indicates if the level numbers should be shown. This is -- recommended for any trace that involves backtracking, because only the level -- numbers will allow to keep track of backjumps.-showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]+showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b showMessages p sl = go [] 0   where-    go :: [Var QPN] -> Int -> [Message] -> [String]-    go _ _ []                            = []+    -- The stack 'v' represents variables that are currently assigned by the+    -- solver.  'go' pushes a variable for a recursive call when it encounters+    -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'.+    -- When 'go' processes a package goal, or a package goal followed by a+    -- 'Failure', it calls 'atLevel' with the goal variable at the head of the+    -- stack so that the predicate can also select messages relating to package+    -- goal choices.+    go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b+    go !_ !_ (Done x)                           = Done x+    go !_ !_ (Fail x)                           = Fail x     -- complex patterns-    go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms-    go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)-    go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)-    go v l (Next (Goal (P qpn) gr) : TryP qpn' i : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)-    go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms+    go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        goPReject v l qpn [i] c fr ms+    go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =+        (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =+        let v' = add (P qpn) v+        in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)+    go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))+        | c == c' = go v l ms     -- standard display-    go v l (Enter                  : ms) = go v          (l+1) ms-    go v l (Leave                  : ms) = go (drop 1 v) (l-1) ms-    go v l (TryP qpn i             : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)-    go v l (TryF qfn b             : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)-    go v l (TryS qsn b             : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)-    go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms)-    go v l (Next _                 : ms) = go v l ms -- ignore flag goals in the log-    go v l (Success                : ms) = (atLevel v l $ "done") (go v l ms)-    go v l (Failure c fr           : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms)+    go !v !l (Step Enter                    ms) = go v          (l+1) ms+    go !v !l (Step Leave                    ms) = go (drop 1 v) (l-1) ms+    go !v !l (Step (TryP qpn i)             ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)+    go !v !l (Step (TryF qfn b)             ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)+    go !v !l (Step (TryS qsn b)             ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)+    go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)+    go !v !l (Step (Next _)                 ms) = go v l ms -- ignore flag goals in the log+    go !v !l (Step (Success)                ms) = (atLevel v l $ "done") (go v l ms)+    go !v !l (Step (Failure c fr)           ms) = (atLevel v l $ showFailure c fr) (go v l ms) +    showPackageGoal :: QPN -> QGoalReasonChain -> String+    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGRs gr++    showFailure :: ConflictSet QPN -> FailReason -> String+    showFailure c fr = "fail" ++ showFR c fr+     add :: Var QPN -> [Var QPN] -> [Var QPN]     add v vs = simplifyVar v : vs      -- special handler for many subsequent package rejections-    goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String]-    goPReject v l qpn is c fr (TryP qpn' i : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms-    goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)+    goPReject :: [Var QPN]+              -> Int+              -> QPN+              -> [POption]+              -> ConflictSet QPN+              -> FailReason+              -> Progress Message a b+              -> Progress String a b+    goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))+      | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms+    goPReject v l qpn is c fr ms =+        (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)      -- write a message, but only if it's relevant; we can also enable or disable the display of the current level+    atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b     atLevel v l x xs       | sl && p v = let s = show l-                    in  ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs-      | p v       = x : xs+                    in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs+      | p v       = Step x xs       | otherwise = xs  showQPNPOpt :: QPN -> POption -> String@@ -106,6 +141,7 @@ showFR c Backjump                         = " (backjumping, conflict set: " ++ showCS c ++ ")" showFR _ MultipleInstances                = " (multiple instances)" showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")"+showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")" -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though.
cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -1,5 +1,36 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.PSQ where+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Client.Dependency.Modular.PSQ+    ( PSQ(..)  -- Unit test needs constructor access+    , Degree(..)+    , casePSQ+    , cons+    , degree+    , delete+    , dminimumBy+    , length+    , lookup+    , filter+    , filterKeys+    , firstOnly+    , fromList+    , isZeroOrOne+    , keys+    , map+    , mapKeys+    , mapWithKey+    , mapWithKeyState+    , minimumBy+    , null+    , prefer+    , preferByKeys+    , preferOrElse+    , snoc+    , sortBy+    , sortByKeys+    , splits+    , toList+    , union+    ) where  -- Priority search queues. --@@ -8,14 +39,17 @@ -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice. -import Data.Foldable+import Control.Arrow (first, second)++import qualified Data.Foldable as F import Data.Function-import Data.List as S hiding (foldr)+import qualified Data.List as S+import Data.Ord (comparing) import Data.Traversable-import Prelude hiding (foldr)+import Prelude hiding (foldr, length, lookup, filter, null, map)  newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show, Functor, Foldable, Traversable)+  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP  keys :: PSQ k v -> [k] keys (PSQ xs) = fmap fst xs@@ -24,22 +58,22 @@ lookup k (PSQ xs) = S.lookup k xs  map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2-map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs)+map f (PSQ xs) = PSQ (fmap (second f) xs)  mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v-mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs)+mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)  mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)  mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b mapWithKeyState p (PSQ xs) s0 =-  PSQ (foldr (\ (k, v) r s -> case p s k v of-                                (w, n) -> (k, w) : (r n))-             (const []) xs s0)+  PSQ (F.foldr (\ (k, v) r s -> case p s k v of+                                  (w, n) -> (k, w) : (r n))+               (const []) xs s0)  delete :: Eq k => k -> PSQ k a -> PSQ k a-delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs))+delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs))  fromList :: [(k, a)] -> PSQ k a fromList = PSQ@@ -69,6 +103,62 @@ sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) +-- | Given a measure in form of a pseudo-peano-natural number,+-- determine the approximate minimum. This is designed to stop+-- even traversing the list as soon as we find any element with+-- measure 'ZeroOrOne'.+--+-- Always returns a one-element queue (except if the queue is+-- empty, then we return an empty queue again).+--+dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a+dminimumBy _   (PSQ [])       = PSQ []+dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs+  where+    go ZeroOrOne v _ = PSQ [v]+    go _ v []        = PSQ [v]+    go c v (y : ys)  = case compare c d of+      LT -> go c v ys+      EQ -> go c v ys+      GT -> go d y ys+      where+        d = sel (snd y)++minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a+minimumBy sel (PSQ xs) =+  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]++-- | Will partition the list according to the predicate. If+-- there is any element that satisfies the precidate, then only+-- the elements satisfying the predicate are returned.+-- Otherwise, the rest is returned.+--+prefer :: (a -> Bool) -> PSQ k a -> PSQ k a+prefer p (PSQ xs) =+  let+    (pro, con) = S.partition (p . snd) xs+  in+    if S.null pro then PSQ con else PSQ pro++-- | Variant of 'prefer' that takes a continuation for the case+-- that there are none of the desired elements.+preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a+preferOrElse p k (PSQ xs) =+  let+    (pro, con) = S.partition (p . snd) xs+  in+    if S.null pro then k (PSQ con) else PSQ pro++-- | Variant of 'prefer' that takes a predicate on the keys+-- rather than on the values.+--+preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+preferByKeys p (PSQ xs) =+  let+    (pro, con) = S.partition (p . fst) xs+  in+    if S.null pro then PSQ con else PSQ pro+ filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) @@ -78,17 +168,43 @@ length :: PSQ k a -> Int length (PSQ xs) = S.length xs --- | "Lazy length".+-- | Approximation of the branching degree. ----- Only approximates the length, but doesn't force the list.-llength :: PSQ k a -> Int-llength (PSQ [])       = 0-llength (PSQ (_:[]))   = 1-llength (PSQ (_:_:[])) = 2-llength (PSQ _)        = 3+-- This is designed for computing the branching degree of a goal choice+-- node. If the degree is 0 or 1, it is always good to take that goal,+-- because we can either abort immediately, or have no other choice anyway.+--+-- So we do not actually want to compute the full degree (which is+-- somewhat costly) in cases where we have such an easy choice.+--+data Degree = ZeroOrOne | Two | Other+  deriving (Show, Eq) +instance Ord Degree where+  compare ZeroOrOne _         = LT -- lazy approximation+  compare _         ZeroOrOne = GT -- approximation+  compare Two       Two       = EQ+  compare Two       Other     = LT+  compare Other     Two       = GT+  compare Other     Other     = EQ++degree :: PSQ k a -> Degree+degree (PSQ [])     = ZeroOrOne+degree (PSQ [_])    = ZeroOrOne+degree (PSQ [_, _]) = Two+degree (PSQ _)      = Other+ null :: PSQ k a -> Bool null (PSQ xs) = S.null xs++isZeroOrOne :: PSQ k a -> Bool+isZeroOrOne (PSQ [])  = True+isZeroOrOne (PSQ [_]) = True+isZeroOrOne _         = False++firstOnly :: PSQ k a -> PSQ k a+firstOnly (PSQ [])      = PSQ []+firstOnly (PSQ (x : _)) = PSQ [x]  toList :: PSQ k a -> [(k, a)] toList (PSQ xs) = xs
cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs view
@@ -1,7 +1,26 @@ {-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Package-  (module Distribution.Client.Dependency.Modular.Package,-   module Distribution.Package) where+  ( I(..)+  , Loc(..)+  , PackageId+  , PackageIdentifier(..)+  , PackageName(..)+  , PI(..)+  , PN+  , PP(..)+  , Namespace(..)+  , Qualifier(..)+  , QPN+  , QPV+  , Q(..)+  , instI+  , makeIndependent+  , primaryPP+  , showI+  , showPI+  , showQPN+  , unPN+  ) where  import Data.List as L @@ -24,7 +43,7 @@ type QPV = Q PV  -- | Package id. Currently just a black-box string.-type PId = InstalledPackageId+type PId = UnitId  -- | Location. Info about whether a package is installed or not, and where -- exactly it is located. For installed packages, uniquely identifies the@@ -41,11 +60,13 @@ -- | String representation of an instance. showI :: I -> String showI (I v InRepo)   = showVer v-showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i+showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid   where     -- A hack to extract the beginning of the package ABI hash-    shortId = snip (splitAt 4) (++ "...") .-              snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+    shortId (SimpleUnitId (ComponentId i))+            = snip (splitAt 4) (++ "...")+            . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)+            $ i     snip p f xs = case p xs of                     (ys, zs) -> (if L.null zs then id else f) ys @@ -57,46 +78,79 @@ showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i --- | Checks if a package instance corresponds to an installed package.-instPI :: PI qpn -> Bool-instPI (PI _ (I _ (Inst _))) = True-instPI _                     = False- instI :: I -> Bool instI (I _ (Inst _)) = True instI _              = False --- | Package path.+-- | A package path consists of a namespace and a package path inside that+-- namespace.+data PP = PP Namespace Qualifier+  deriving (Eq, Ord, Show)++-- | Top-level namespace ----- Stored in reverse order-data PP =-    -- User-specified independent goal-    Independent Int PP-    -- Setup dependencies are always considered independent from their package-  | Setup PN PP-    -- Any dependency on base is considered independent (allows for base shims)-  | Base PN PP-    -- Unqualified-  | None+-- Package choices in different namespaces are considered completely independent+-- by the solver.+data Namespace =+    -- | The default namespace+    DefaultNamespace++    -- | Independent namespace+    --+    -- For now we just number these (rather than giving them more structure).+  | Independent Int   deriving (Eq, Ord, Show) --- | Strip any 'Base' qualifiers from a PP+-- | Qualifier of a package within a namespace (see 'PP')+data Qualifier =+    -- | Top-level dependency in this namespace+    Unqualified++    -- | Any dependency on base is considered independent+    --+    -- This makes it possible to have base shims.+  | Base PN++    -- | Setup dependency+    --+    -- By rights setup dependencies ought to be nestable; after all, the setup+    -- dependencies of a package might themselves have setup dependencies, which+    -- are independent from everything else. However, this very quickly leads to+    -- infinite search trees in the solver. Therefore we limit ourselves to+    -- a single qualifier (within a given namespace).+  | Setup PN+  deriving (Eq, Ord, Show)++-- | Is the package in the primary group of packages. In particular this+-- does not include packages pulled in as setup deps. ----- (the Base qualifier does not get inherited)-stripBase :: PP -> PP-stripBase (Independent i pp) = Independent i (stripBase pp)-stripBase (Setup pn      pp) = Setup pn      (stripBase pp)-stripBase (Base _pn      pp) =                stripBase pp-stripBase None               = None+primaryPP :: PP -> Bool+primaryPP (PP _ns q) = go q+  where+    go Unqualified = True+    go (Base  _)   = True+    go (Setup _)   = False  -- | String representation of a package path. ----- NOTE: This always ends in a period+-- NOTE: The result of 'showPP' is either empty or results in a period, so that+-- it can be prepended to a package name. showPP :: PP -> String-showPP (Independent i pp) = show i                 ++ "." ++ showPP pp-showPP (Setup pn      pp) = display pn ++ "-setup" ++ "." ++ showPP pp-showPP (Base  pn      pp) = display pn             ++ "." ++ showPP pp-showPP None               = ""+showPP (PP ns q) =+    case ns of+      DefaultNamespace -> go q+      Independent i    -> show i ++ "." ++ go q+  where+    -- Print the qualifier+    --+    -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is+    -- there to make sure different dependencies on base are all independent.+    -- So we want to print something like @"A.base"@, where the @"A."@ part+    -- is the qualifier and @"base"@ is the actual dependency (which, for the+    -- 'Base' qualifier, will always be @base@).+    go Unqualified = ""+    go (Setup pn)  = display pn ++ "-setup."+    go (Base  pn)  = display pn ++ "."  -- | A qualified entity. Pairs a package path with the entity. data Q a = Q PP a@@ -104,8 +158,7 @@  -- | Standard string representation of a qualified entity. showQ :: (a -> String) -> (Q a -> String)-showQ showa (Q None x) = showa x-showQ showa (Q pp   x) = showPP pp ++ showa x+showQ showa (Q pp x) = showPP pp ++ showa x  -- | Qualified package name. type QPN = Q PN@@ -118,8 +171,5 @@ -- them all independent. makeIndependent :: [PN] -> [QPN] makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]-                               , let pp = Independent i None+                               , let pp = PP (Independent i) Unqualified                      ]--unQualify :: Q a -> a-unQualify (Q _ x) = x
cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs view
@@ -1,5 +1,19 @@ {-# LANGUAGE CPP #-}-module Distribution.Client.Dependency.Modular.Preference where+module Distribution.Client.Dependency.Modular.Preference+    ( avoidReinstalls+    , deferSetupChoices+    , deferWeakFlagChoices+    , enforceManualFlags+    , enforcePackageConstraints+    , enforceSingleInstanceRestriction+    , firstGoal+    , preferBaseGoalChoice+    , preferEasyGoalChoices+    , preferLinked+    , preferPackagePreferences+    , preferReallyEasyGoalChoices+    , requireInstalled+    ) where  -- Reordering or pruning the tree in order to prefer or make certain choices. @@ -12,12 +26,11 @@ import qualified Data.Set as S import Prelude hiding (sequence) import Control.Monad.Reader hiding (sequence)-import Data.Ord import Data.Map (Map) import Data.Traversable (sequence)  import Distribution.Client.Dependency.Types-  ( PackageConstraint(..), LabeledPackageConstraint(..)+  ( PackageConstraint(..), LabeledPackageConstraint(..), ConstraintSource(..)   , PackagePreferences(..), InstalledPreference(..) ) import Distribution.Client.Types   ( OptionalStanza(..) )@@ -25,7 +38,7 @@ import Distribution.Client.Dependency.Modular.Dependency import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree import Distribution.Client.Dependency.Modular.Version @@ -56,21 +69,23 @@     cmpL (Just _) Nothing  = LT     cmpL (Just _) (Just _) = EQ ---- | Ordering that treats preferred versions as greater than non-preferred--- versions.-preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering-preferredVersionsOrdering vr v1 v2 =-  compare (checkVR vr v1) (checkVR vr v2)+-- | Ordering that treats versions satisfying more preferred ranges as greater+--   than versions satisfying less preferred ranges.+preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering+preferredVersionsOrdering vrs v1 v2 = compare (check v1) (check v2)+  where+     check v = Prelude.length . Prelude.filter (==True) .+               Prelude.map (flip checkVR v) $ vrs  -- | Traversal that tries to establish package preferences (not constraints).--- Works by reordering choice nodes.+-- Works by reordering choice nodes. Also applies stanza preferences. preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a-preferPackagePreferences pcs = packageOrderFor (const True) preference+preferPackagePreferences pcs = preferPackageStanzaPreferences pcs+                             . packageOrderFor (const True) preference   where     preference pn i1@(I v1 _) i2@(I v2 _) =-      let PackagePreferences vr ipref = pcs pn-      in  preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically+      let PackagePreferences vrs ipref _ = pcs pn+      in  preferredVersionsOrdering vrs v1 v2 `mappend` -- combines lexically           locationsOrdering ipref i1 i2      -- Note that we always rank installed before uninstalled, and later@@ -92,16 +107,36 @@ preferLatestOrdering :: I -> I -> Ordering preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 +-- | Traversal that tries to establish package stanza enable\/disable+-- preferences. Works by reordering the branches of stanza choices.+preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a+preferPackageStanzaPreferences pcs = trav go+  where+    go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) | primaryPP pp =+        let PackagePreferences _ _ spref = pcs pn+            enableStanzaPref = s `elem` spref+                  -- move True case first to try enabling the stanza+            ts' | enableStanzaPref = P.sortByKeys (flip compare) ts+                | otherwise        = ts+         in SChoiceF qsn gr True ts'   -- True: now weak choice+    go x = x+ -- | Helper function that tries to enforce a single package constraint on a -- given instance for a P-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node.-processPackageConstraintP :: ConflictSet QPN+processPackageConstraintP :: PP+                          -> ConflictSet QPN                           -> I                           -> LabeledPackageConstraint                           -> Tree a                           -> Tree a-processPackageConstraintP c i (LabeledPackageConstraint pc src) r = go i pc+processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r+  | src == ConstraintSourceUserTarget && not (primaryPP pp)         = r+    -- the constraints arising from targets, like "foo-1.0" only apply to+    -- the main packages in the solution, they don't constrain setup deps++processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc   where     go (I v _) (PackageConstraintVersion _ vr)         | checkVR vr v  = r@@ -158,10 +193,10 @@                           -> Tree QGoalReasonChain enforcePackageConstraints pcs = trav go   where-    go (PChoiceF qpn@(Q _ pn)               gr      ts) =+    go (PChoiceF qpn@(Q pp pn)              gr      ts) =       let c = toConflictSet (Goal (P qpn) gr)           -- compose the transformation functions for each of the relevant constraint-          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP   c i pc) id+          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id                            (M.findWithDefault [] pn pcs)       in PChoiceF qpn gr      (P.mapWithKey g ts)     go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) =@@ -196,22 +231,6 @@         isDisabled _                                    = False     go x                                                   = x --- | Prefer installed packages over non-installed packages, generally.--- All installed packages or non-installed packages are treated as--- equivalent.-preferInstalled :: Tree a -> Tree a-preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering)---- | Prefer packages with higher version numbers over packages with--- lower version numbers, for certain packages.-preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a-preferLatestFor p = packageOrderFor p (const preferLatestOrdering)---- | Prefer packages with higher version numbers over packages with--- lower version numbers, for all packages.-preferLatest :: Tree a -> Tree a-preferLatest = preferLatestFor (const True)- -- | Require installed packages. requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain requireInstalled p = trav go@@ -245,7 +264,7 @@       | otherwise = PChoiceF qpn gr cs       where         disableReinstalls =-          let installed = [ v | (POption (I v (Inst _)) _, _) <- toList cs ]+          let installed = [ v | (POption (I v (Inst _)) _, _) <- P.toList cs ]           in  P.mapWithKey (notReinstall installed) cs          notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =@@ -263,8 +282,7 @@ firstGoal :: Tree a -> Tree a firstGoal = trav go   where-    go (GoalChoiceF xs) = -- casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info-                          casePSQ xs (GoalChoiceF (fromList [])) (\ g t _ -> GoalChoiceF (fromList [(g, t)]))+    go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)     go x                = x     -- Note that we keep empty choice nodes, because they mean success. @@ -274,37 +292,24 @@ preferBaseGoalChoice :: Tree a -> Tree a preferBaseGoalChoice = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)     go x                = x -    preferBase :: OpenGoal comp -> OpenGoal comp -> Ordering-    preferBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) _ | unPN pn == "base" = LT-    preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT-    preferBase _ _                                                              = EQ+    isBase :: OpenGoal comp -> Bool+    isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True+    isBase _                                                              = False  -- | Deal with setup dependencies after regular dependencies, so that we can -- will link setup depencencies against package dependencies when possible deferSetupChoices :: Tree a -> Tree a deferSetupChoices = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys deferSetup xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)     go x                = x -    deferSetup :: OpenGoal comp -> OpenGoal comp -> Ordering-    deferSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) _ = GT-    deferSetup _ (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = LT-    deferSetup _ _                                                 = EQ---- | Transformation that sorts choice nodes so that--- child nodes with a small branching degree are preferred. As a--- special case, choices with 0 branches will be preferred (as they--- are immediately considered inconsistent), and choices with 1--- branch will also be preferred (as they don't involve choice).-preferEasyGoalChoices :: Tree a -> Tree a-preferEasyGoalChoices = trav go-  where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)-    go x                = x+    noSetup :: OpenGoal comp -> Bool+    noSetup (OpenGoal (Simple (Dep (Q (PP _ns (Setup _)) _) _) _) _) = False+    noSetup _                                                        = True  -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such@@ -312,33 +317,45 @@ deferWeakFlagChoices :: Tree a -> Tree a deferWeakFlagChoices = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))     go x                = x -    defer :: Tree a -> Tree a -> Ordering-    defer (FChoice _ _ True _ _) _ = GT-    defer _ (FChoice _ _ True _ _) = LT-    defer _ _                      = EQ+    noWeakStanza :: Tree a -> Bool+    noWeakStanza (SChoice _ _ True _) = False+    noWeakStanza _                    = True --- | Variant of 'preferEasyGoalChoices'.+    noWeakFlag :: Tree a -> Bool+    noWeakFlag (FChoice _ _ True _ _) = False+    noWeakFlag _                      = True++-- | Transformation that sorts choice nodes so that+-- child nodes with a small branching degree are preferred. ----- Only approximates the number of choices in the branches. Less accurate,--- more efficient.-lpreferEasyGoalChoices :: Tree a -> Tree a-lpreferEasyGoalChoices = trav go+-- Only approximates the number of choices in the branches.+-- In particular, we try to take any goal immediately if it has+-- a branching degree of 0 (guaranteed failure) or 1 (no other+-- choice possible).+--+-- Returns at most one choice.+--+preferEasyGoalChoices :: Tree a -> Tree a+preferEasyGoalChoices = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs)+    go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)+      -- (a different implementation that seems slower):+      -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs))     go x                = x --- | Variant of 'preferEasyGoalChoices'.+-- | A variant of 'preferEasyGoalChoices' that just keeps the+-- ones with a branching degree of 0 or 1. Note that unlike+-- 'preferEasyGoalChoices', this may return more than one+-- choice. ----- I first thought that using a paramorphism might be faster here,--- but it doesn't seem to make any difference.-preferEasyGoalChoices' :: Tree a -> Tree a-preferEasyGoalChoices' = para (inn . go)+preferReallyEasyGoalChoices :: Tree a -> Tree a+preferReallyEasyGoalChoices = trav go   where-    go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs))-    go x                = fmap fst x+    go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs)+    go x                = x  -- | Monad used internally in enforceSingleInstanceRestriction type EnforceSIR = Reader (Map (PI PN) QPN)
cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs view
@@ -1,11 +1,19 @@-module Distribution.Client.Dependency.Modular.Solver where+module Distribution.Client.Dependency.Modular.Solver+    ( SolverConfig(..)+    , solve+    ) where  import Data.Map as M +import Distribution.Compiler (CompilerInfo)++import Distribution.Client.PkgConfigDb (PkgConfigDb)+ import Distribution.Client.Dependency.Types  import Distribution.Client.Dependency.Modular.Assignment import Distribution.Client.Dependency.Modular.Builder+import Distribution.Client.Dependency.Modular.Cycles import Distribution.Client.Dependency.Modular.Dependency import Distribution.Client.Dependency.Modular.Explore import Distribution.Client.Dependency.Modular.Index@@ -26,35 +34,62 @@   maxBackjumps          :: Maybe Int } -solve :: SolverConfig ->          -- solver parameters-         Index ->                 -- all available packages as an index-         (PN -> PackagePreferences) ->        -- preferences-         Map PN [LabeledPackageConstraint] -> -- global constraints-         [PN] ->                              -- global goals+-- | Run all solver phases.+--+-- In principle, we have a valid tree after 'validationPhase', which+-- means that every 'Done' node should correspond to valid solution.+--+-- There is one exception, though, and that is cycle detection, which+-- has been added relatively recently. Cycles are only removed directly+-- before exploration.+--+-- Semantically, there is no difference. Cycle detection, as implemented+-- now, only occurs for 'Done' nodes we encounter during exploration,+-- and cycle detection itself does not change the shape of the tree,+-- it only marks some 'Done' nodes as 'Fail', if they contain cyclic+-- solutions.+--+-- There is a tiny performance impact, however, in doing cycle detection+-- directly after validation. Probably because cycle detection maintains+-- some information, and the various reorderings implemented by+-- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more+-- costly if that information is already around during the reorderings.+--+-- With the current positioning directly before the 'explorePhase', there+-- seems to be no statistically significant performance impact of cycle+-- detection in the common case where there are no cycles.+--+solve :: SolverConfig ->                      -- ^ solver parameters+         CompilerInfo ->+         Index ->                             -- ^ all available packages as an index+         PkgConfigDb ->                       -- ^ available pkg-config pkgs+         (PN -> PackagePreferences) ->        -- ^ preferences+         Map PN [LabeledPackageConstraint] -> -- ^ global constraints+         [PN] ->                              -- ^ global goals          Log Message (Assignment, RevDepMap)-solve sc idx userPrefs userConstraints userGoals =+solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =   explorePhase     $+  detectCyclesPhase$   heuristicsPhase  $   preferencesPhase $   validationPhase  $   prunePhase       $   buildPhase   where-    explorePhase     = exploreTreeLog . backjump-    heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)-                       P.deferSetupChoices .+    explorePhase     = backjumpAndExplore+    heuristicsPhase  = (if preferEasyGoalChoices sc+                         then P.preferEasyGoalChoices -- also leaves just one choice+                         else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)                        P.deferWeakFlagChoices .+                       P.deferSetupChoices .                        P.preferBaseGoalChoice .-                       if preferEasyGoalChoices sc-                         then P.lpreferEasyGoalChoices-                         else id .                        P.preferLinked     preferencesPhase = P.preferPackagePreferences userPrefs     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints                        P.enforcePackageConstraints userConstraints .                        P.enforceSingleInstanceRestriction .                        validateLinking idx .-                       validateTree idx+                       validateTree cinfo idx pkgConfigDB     prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .                        -- packages that can never be "upgraded":                        P.requireInstalled (`elem` [ PackageName "base"
cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs view
@@ -1,5 +1,19 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Client.Dependency.Modular.Tree where+module Distribution.Client.Dependency.Modular.Tree+    ( FailReason(..)+    , POption(..)+    , Tree(..)+    , TreeF(..)+    , ana+    , cata+    , choices+    , dchoices+    , inn+    , innM+    , para+    , trav+    , zeroOrOneChoices+    ) where  import Control.Monad hiding (mapM, sequence) import Data.Foldable@@ -9,7 +23,8 @@ import Distribution.Client.Dependency.Modular.Dependency import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+import Distribution.Client.Dependency.Modular.PSQ (PSQ)+import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Version import Distribution.Client.Dependency.Types ( ConstraintSource(..) ) @@ -42,7 +57,7 @@ -- -- Linking is an essential part of this story. In addition to picking a specific -- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or--- vice versa). Teans that @1.P@ and @0.P@ really must be the very same package+-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package -- (and hence must have the same build time configuration, and their -- dependencies must also be the exact same). --@@ -68,6 +83,7 @@                 | Backjump                 | MultipleInstances                 | DependenciesNotLinked String+                | CyclicDependencies   deriving (Eq, Show)  -- | Functor for the tree type.@@ -119,16 +135,24 @@ choices (Done       _         ) = 1 choices (Fail       _ _       ) = 0 --- | Variant of 'choices' that only approximates the number of choices,--- using 'llength'.-lchoices :: Tree a -> Int-lchoices (PChoice    _ _     ts) = P.llength (P.filter active ts)-lchoices (FChoice    _ _ _ _ ts) = P.llength (P.filter active ts)-lchoices (SChoice    _ _ _   ts) = P.llength (P.filter active ts)-lchoices (GoalChoice         _ ) = 1-lchoices (Done       _         ) = 1-lchoices (Fail       _ _       ) = 0+-- | Variant of 'choices' that only approximates the number of choices.+dchoices :: Tree a -> P.Degree+dchoices (PChoice    _ _     ts) = P.degree (P.filter active ts)+dchoices (FChoice    _ _ _ _ ts) = P.degree (P.filter active ts)+dchoices (SChoice    _ _ _   ts) = P.degree (P.filter active ts)+dchoices (GoalChoice         _ ) = P.ZeroOrOne+dchoices (Done       _         ) = P.ZeroOrOne+dchoices (Fail       _ _       ) = P.ZeroOrOne +-- | Variant of 'choices' that only approximates the number of choices.+zeroOrOneChoices :: Tree a -> Bool+zeroOrOneChoices (PChoice    _ _     ts) = P.isZeroOrOne (P.filter active ts)+zeroOrOneChoices (FChoice    _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)+zeroOrOneChoices (SChoice    _ _ _   ts) = P.isZeroOrOne (P.filter active ts)+zeroOrOneChoices (GoalChoice         _ ) = True+zeroOrOneChoices (Done       _         ) = True+zeroOrOneChoices (Fail       _ _       ) = True+ -- | Catamorphism on trees. cata :: (TreeF a b -> b) -> Tree a -> b cata phi x = (phi . fmap (cata phi) . out) x@@ -140,12 +164,6 @@ para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b para phi = phi . fmap (\ x -> (para phi x, x)) . out -cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b-cataM phi = phi <=< mapM (cataM phi) <=< return . out- -- | Anamorphism on trees. ana :: (b -> TreeF a b) -> b -> Tree a ana psi = inn . fmap (ana psi) . psi--anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a)-anaM psi = return . inn <=< mapM (anaM psi) <=< psi
cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs view
@@ -10,18 +10,25 @@ import Control.Monad.Reader hiding (sequence) import Data.List as L import Data.Map as M+import Data.Set as S import Data.Traversable import Prelude hiding (sequence) +import Language.Haskell.Extension (Extension, Language)++import Distribution.Compiler (CompilerInfo(..))+ import Distribution.Client.Dependency.Modular.Assignment import Distribution.Client.Dependency.Modular.Dependency import Distribution.Client.Dependency.Modular.Flag import Distribution.Client.Dependency.Modular.Index import Distribution.Client.Dependency.Modular.Package-import Distribution.Client.Dependency.Modular.PSQ as P+import qualified Distribution.Client.Dependency.Modular.PSQ as P import Distribution.Client.Dependency.Modular.Tree+import Distribution.Client.Dependency.Modular.Version (VR)  import Distribution.Client.ComponentDeps (Component)+import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)  -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints@@ -75,6 +82,9 @@  -- | The state needed during validation. data ValidateState = VS {+  supportedExt  :: Extension -> Bool,+  supportedLang :: Language  -> Bool,+  presentPkgs   :: PN -> VR  -> Bool,   index :: Index,   saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies   pa    :: PreAssignment,@@ -123,6 +133,9 @@     goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goP qpn@(Q _pp pn) gr (POption i _) r = do       PA ppa pfa psa <- asks pa    -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs       idx            <- asks index -- obtain the index       svd            <- asks saved -- obtain saved dependencies       qo             <- asks qualifyOptions@@ -135,7 +148,7 @@       let goal = Goal (P qpn) gr       let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)       -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend (P qpn) ppa newactives+      let mnppa = extend extSupported langSupported pkgPresent goal ppa newactives       -- In case we continue, we save the scoped dependencies       let nsvd = M.insert qpn qdeps svd       case mfr of@@ -151,6 +164,9 @@     goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goF qfn@(FN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs       svd <- asks saved         -- obtain saved dependencies       -- Note that there should be saved dependencies for the package in question,       -- because while building, we do not choose flags before we see the packages@@ -165,7 +181,7 @@       -- we have chosen a new flag.       let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps       -- As in the package case, we try to extend the partial assignment.-      case extend (F qfn) ppa newactives of+      case extend extSupported langSupported pkgPresent (Goal (F qfn) gr) ppa newactives of         Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found         Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r @@ -173,6 +189,9 @@     goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goS qsn@(SN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs       svd <- asks saved         -- obtain saved dependencies       -- Note that there should be saved dependencies for the package in question,       -- because while building, we do not choose flags before we see the packages@@ -187,7 +206,7 @@       -- we have chosen a new flag.       let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps       -- As in the package case, we try to extend the partial assignment.-      case extend (S qsn) ppa newactives of+      case extend extSupported langSupported pkgPresent (Goal (S qsn) gr) ppa newactives of         Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found         Right nppa  -> local (\ s -> s { pa = PA nppa pfa npsa }) r @@ -235,10 +254,17 @@                                   Just False -> []  -- | Interface.-validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain-validateTree idx t = runReader (validate t) VS {-    index = idx-  , saved = M.empty-  , pa    = PA M.empty M.empty M.empty+validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree QGoalReasonChain -> Tree QGoalReasonChain+validateTree cinfo idx pkgConfigDb t = runReader (validate t) VS {+    supportedExt   = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported+                           (\ es -> let s = S.fromList es in \ x -> S.member x s)+                           (compilerInfoExtensions cinfo)+  , supportedLang  = maybe (const True)+                           (flip L.elem) -- use list lookup because language list is small and no Ord instance+                           (compilerInfoLanguages  cinfo)+  , presentPkgs    = pkgConfigPkgIsPresent pkgConfigDb+  , index          = idx+  , saved          = M.empty+  , pa             = PA M.empty M.empty M.empty   , qualifyOptions = defaultQualifyOptions idx   }
cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs view
@@ -1,4 +1,15 @@-module Distribution.Client.Dependency.Modular.Version where+module Distribution.Client.Dependency.Modular.Version+    ( Ver+    , VR+    , anyVR+    , checkVR+    , eqVR+    , showVer+    , showVR+    , simplifyVR+    , (.&&.)+    , (.||.)+    ) where  import qualified Distribution.Version as CV -- from Cabal import Distribution.Text -- from Cabal@@ -29,6 +40,10 @@ (.&&.) :: VR -> VR -> VR (.&&.) = CV.intersectVersionRanges +-- | Union of two version ranges.+(.||.) :: VR -> VR -> VR+(.||.) = CV.unionVersionRanges+ -- | Simplify a version range. simplifyVR :: VR -> VR simplifyVR = CV.simplifyVersionRange@@ -36,7 +51,3 @@ -- | Checking a version against a version range. checkVR :: VR -> Ver -> Bool checkVR = flip CV.withinRange---- | Make a version number.-mkV :: [Int] -> Ver-mkV xs = CV.Version xs []
cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs view
@@ -21,7 +21,8 @@          ( Satisfiable(..) ) import Distribution.Client.Types          ( SourcePackage(..), ConfiguredPackage(..)-         , enableStanzas, ConfiguredId(..), fakeInstalledPackageId )+         , UnresolvedPkgLoc, UnresolvedSourcePackage+         , enableStanzas, ConfiguredId(..), fakeUnitId ) import Distribution.Client.Dependency.Types          ( DependencyResolver, ResolverPackage(..)          , PackageConstraint(..), unlabelPackageConstraint@@ -39,7 +40,7 @@          ( PackageIndex ) import Distribution.Package          ( PackageName(..), PackageId, PackageIdentifier(..)-         , InstalledPackageId(..)+         , UnitId(..), ComponentId(..)          , Package(..), packageVersion, packageName          , Dependency(Dependency), thisPackageVersion, simplifyDependency ) import Distribution.PackageDescription@@ -127,8 +128,10 @@       where         isInstalled (SourceOnly _) = False         isInstalled _              = True-        isPreferred p = packageVersion p `withinRange` preferredVersions-        (PackagePreferences preferredVersions packageInstalledPreference)+        isPreferred p = length . filter (packageVersion p `withinRange`) $+                        preferredVersions++        (PackagePreferences preferredVersions packageInstalledPreference _)           = pref pkgname      logInfo node = Select selected discarded@@ -248,8 +251,8 @@ -- | The main exported resolver, with string logging and failure types to fit -- the standard 'DependencyResolver' interface. ---topDownResolver :: DependencyResolver-topDownResolver platform cinfo installedPkgIndex sourcePkgIndex+topDownResolver :: DependencyResolver UnresolvedPkgLoc+topDownResolver platform cinfo installedPkgIndex sourcePkgIndex _pkgConfigDB                 preferences constraints targets =     mapMessages $ topDownResolver'                     platform cinfo@@ -266,11 +269,11 @@ -- topDownResolver' :: Platform -> CompilerInfo                  -> PackageIndex InstalledPackage-                 -> PackageIndex SourcePackage+                 -> PackageIndex UnresolvedSourcePackage                  -> (PackageName -> PackagePreferences)                  -> [PackageConstraint]                  -> [PackageName]-                 -> Progress Log Failure [ResolverPackage]+                 -> Progress Log Failure [ResolverPackage UnresolvedPkgLoc] topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex                  preferences constraints targets =       fmap (uncurry finalise)@@ -298,7 +301,7 @@       . PackageIndex.fromList       $ finaliseSelectedPackages preferences selected' constraints' -    toResolverPackage :: FinalSelectedPackage -> ResolverPackage+    toResolverPackage :: FinalSelectedPackage -> ResolverPackage UnresolvedPkgLoc     toResolverPackage (SelectedInstalled (InstalledPackage pkg _))                                               = PreExisting pkg     toResolverPackage (SelectedSource    pkg) = Configured  pkg@@ -444,7 +447,7 @@ -- annotateSourcePackages :: [PackageConstraint]                        -> (PackageName -> TopologicalSortNumber)-                       -> PackageIndex SourcePackage+                       -> PackageIndex UnresolvedSourcePackage                        -> PackageIndex UnconfiguredPackage annotateSourcePackages constraints dfsNumber sourcePkgIndex =     PackageIndex.fromList@@ -481,7 +484,7 @@ -- heuristic. -- topologicalSortNumbering :: PackageIndex InstalledPackage-                         -> PackageIndex SourcePackage+                         -> PackageIndex UnresolvedSourcePackage                          -> (PackageName -> TopologicalSortNumber) topologicalSortNumbering installedPkgIndex sourcePkgIndex =     \pkgname -> let Just vertex = toVertex pkgname@@ -508,17 +511,17 @@ -- and looking at the names of all possible dependencies. -- selectNeededSubset :: PackageIndex InstalledPackage-                   -> PackageIndex SourcePackage+                   -> PackageIndex UnresolvedSourcePackage                    -> Set PackageName                    -> (PackageIndex InstalledPackage-                      ,PackageIndex SourcePackage)+                      ,PackageIndex UnresolvedSourcePackage) selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty   where     select :: PackageIndex InstalledPackage-           -> PackageIndex SourcePackage+           -> PackageIndex UnresolvedSourcePackage            -> Set PackageName            -> (PackageIndex InstalledPackage-              ,PackageIndex SourcePackage)+              ,PackageIndex UnresolvedSourcePackage)     select installedPkgIndex' sourcePkgIndex' remaining       | Set.null remaining = (installedPkgIndex', sourcePkgIndex')       | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''@@ -567,9 +570,9 @@     | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ]   where     -- The InstalledPackageInfo only lists dependencies by the-    -- InstalledPackageId, which means we do not directly know the corresponding+    -- UnitId, which means we do not directly know the corresponding     -- source dependency. The only way to find out is to lookup the-    -- InstalledPackageId to get the InstalledPackageInfo and look at its+    -- UnitId to get the InstalledPackageInfo and look at its     -- source PackageId. But if the package is broken because it depends on     -- other packages that do not exist then we have a problem we cannot find     -- the original source package id. Instead we make up a bogus package id.@@ -578,10 +581,10 @@     sourceDepsOf index ipkg =       [ maybe (brokenPackageId depid) packageId mdep       | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupInstalledPackageId index+            getpkg = InstalledPackageIndex.lookupUnitId index       , (depid, mdep) <- zip depids (map getpkg depids) ] -    brokenPackageId (InstalledPackageId str) =+    brokenPackageId (SimpleUnitId (ComponentId str)) =       PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])  -- ------------------------------------------------------------@@ -614,7 +617,8 @@         -- We cheat in the cabal solver, and classify all dependencies as         -- library dependencies.         deps' :: ComponentDeps [ConfiguredId]-        deps' = CD.fromLibraryDeps $ map (confId . pickRemaining mipkg) deps+        deps' = CD.fromLibraryDeps (unPackageName (packageName pkg))+                                   (map (confId . pickRemaining mipkg) deps)      -- InstalledOrSource indicates that we either have a source package     -- available, or an installed one, or both. In the case that we have both@@ -644,7 +648,7 @@     confId :: InstalledOrSource InstalledPackageEx UnconfiguredPackage -> ConfiguredId     confId pkg = ConfiguredId {         confSrcId  = packageId pkg-      , confInstId = fakeInstalledPackageId (packageId pkg)+      , confInstId = fakeUnitId (packageId pkg)       }      pickRemaining mipkg dep@(Dependency _name versionRange) =@@ -669,9 +673,11 @@         -- version constraints. TODO: distinguish hacks from prefs         bounded = boundedAbove versionRange         isPreferred p-          | bounded   = True -- any constant will do-          | otherwise = packageVersion p `withinRange` preferredVersions-          where (PackagePreferences preferredVersions _) = pref (packageName p)+          | bounded   = boundedRank -- this is a dummy constant+          | otherwise = length . filter (packageVersion p `withinRange`) $+                        preferredVersions+          where (PackagePreferences preferredVersions _ _) = pref (packageName p)+        boundedRank = 0 -- any value will do          boundedAbove :: VersionRange -> Bool         boundedAbove vr = case asVersionIntervals vr of
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -14,7 +14,8 @@ module Distribution.Client.Dependency.TopDown.Types where  import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..)+         ( ConfiguredPackage(..)+         , UnresolvedPkgLoc, UnresolvedSourcePackage          , OptionalStanza, ConfiguredId(..) ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo )@@ -44,7 +45,7 @@  data FinalSelectedPackage    = SelectedInstalled InstalledPackage-   | SelectedSource    ConfiguredPackage+   | SelectedSource    (ConfiguredPackage UnresolvedPkgLoc)  type TopologicalSortNumber = Int @@ -62,18 +63,18 @@  data UnconfiguredPackage    = UnconfiguredPackage-       SourcePackage+       UnresolvedSourcePackage        !TopologicalSortNumber        FlagAssignment        [OptionalStanza]  data SemiConfiguredPackage    = SemiConfiguredPackage-       SourcePackage     -- package info-       FlagAssignment    -- total flag assignment for the package-       [OptionalStanza]  -- enabled optional stanzas-       [Dependency]      -- dependencies we end up with when we apply-                         -- the flag assignment+       UnresolvedSourcePackage           -- package info+       FlagAssignment                    -- total flag assignment for the package+       [OptionalStanza]                  -- enabled optional stanzas+       [Dependency]                      -- dependencies we end up with when we apply+                                         -- the flag assignment  instance Package InstalledPackage where   packageId (InstalledPackage pkg _) = packageId pkg@@ -113,9 +114,9 @@ -- -- The top-down solver uses its down type class for package dependencies, -- because it wants to know these dependencies as PackageIds, rather than as--- InstalledPackageIds (so it cannot use PackageFixedDeps).+-- ComponentIds (so it cannot use PackageFixedDeps). ----- Ideally we would switch the top-down solver over to use InstalledPackageIds+-- Ideally we would switch the top-down solver over to use ComponentIds -- throughout; that means getting rid of this type class, and changing over the -- package index type to use Cabal's rather than cabal-install's. That will -- avoid the need for the local definitions of dependencyGraph and@@ -131,8 +132,8 @@ instance PackageSourceDeps InstalledPackageEx where   sourceDeps (InstalledPackageEx _ _ deps) = deps -instance PackageSourceDeps ConfiguredPackage where-  sourceDeps (ConfiguredPackage _ _ _ deps) = map confSrcId $ CD.nonSetupDeps deps+instance PackageSourceDeps (ConfiguredPackage loc) where+  sourceDeps cpkg = map confSrcId $ CD.nonSetupDeps (confPkgDeps cpkg)  instance PackageSourceDeps InstalledPackage where   sourceDeps (InstalledPackage _ deps) = deps
cabal/cabal-install/Distribution/Client/Dependency/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Dependency.Types@@ -18,7 +19,6 @@     DependencyResolver,     ResolverPackage(..), -    AllowNewer(..), isAllowNewer,     PackageConstraint(..),     showPackageConstraint,     PackagePreferences(..),@@ -32,6 +32,7 @@     ConstraintSource(..),     unlabelPackageConstraint,     showConstraintSource+   ) where  #if !MIN_VERSION_base(4,8,0)@@ -48,6 +49,8 @@          ( Monoid(..) ) #endif +import Distribution.Client.PkgConfigDb+         ( PkgConfigDb ) import Distribution.Client.Types          ( OptionalStanza(..), SourcePackage(..), ConfiguredPackage ) @@ -73,18 +76,23 @@  import Text.PrettyPrint          ( text )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..))  import Prelude hiding (fail)   -- | All the solvers that can be selected. data PreSolver = AlwaysTopDown | AlwaysModular | Choose-  deriving (Eq, Ord, Show, Bounded, Enum)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  -- | All the solvers that can be used. data Solver = TopDown | Modular-  deriving (Eq, Ord, Show, Bounded, Enum)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic) +instance Binary PreSolver+instance Binary Solver+ instance Text PreSolver where   disp AlwaysTopDown = text "topdown"   disp AlwaysModular = text "modular"@@ -105,22 +113,23 @@ -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. ---type DependencyResolver = Platform-                       -> CompilerInfo-                       -> InstalledPackageIndex-                       ->          PackageIndex.PackageIndex SourcePackage-                       -> (PackageName -> PackagePreferences)-                       -> [LabeledPackageConstraint]-                       -> [PackageName]-                       -> Progress String String [ResolverPackage]+type DependencyResolver loc = Platform+                           -> CompilerInfo+                           -> InstalledPackageIndex+                           -> PackageIndex.PackageIndex (SourcePackage loc)+                           -> PkgConfigDb+                           -> (PackageName -> PackagePreferences)+                           -> [LabeledPackageConstraint]+                           -> [PackageName]+                           -> Progress String String [ResolverPackage loc]  -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration. -- -- This is like the 'InstallPlan.PlanPackage' but with fewer cases. ---data ResolverPackage = PreExisting InstalledPackageInfo-                     | Configured  ConfiguredPackage+data ResolverPackage loc = PreExisting InstalledPackageInfo+                         | Configured  (ConfiguredPackage loc)  -- | Per-package constraints. Package constraints must be respected by the -- solver. Multiple constraints for each package can be given, though obviously@@ -133,8 +142,10 @@    | PackageConstraintSource    PackageName    | PackageConstraintFlags     PackageName FlagAssignment    | PackageConstraintStanzas   PackageName [OptionalStanza]-  deriving (Show,Eq)+  deriving (Eq,Show,Generic) +instance Binary PackageConstraint+ -- | Provide a textual representation of a package constraint -- for debugging purposes. --@@ -156,17 +167,20 @@     showStanza TestStanzas  = "test"     showStanza BenchStanzas = "bench" --- | A per-package preference on the version. It is a soft constraint that the+-- | Per-package preferences on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of--- a 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also has a 'PackageVersionPreference' which--- is a suggested constraint on the version number. The resolver should try to--- use package versions that satisfy the suggested version constraint.+-- an 'InstalledPreference' which says if we prefer versions of packages+-- that are already installed. It also has (possibly multiple)+-- 'PackageVersionPreference's which are suggested constraints on the version+-- number. The resolver should try to use package versions that satisfy+-- the maximum number of the suggested version constraints. -- -- It is not specified if preferences on some packages are more important than -- others. ---data PackagePreferences = PackagePreferences VersionRange InstalledPreference+data PackagePreferences = PackagePreferences [VersionRange]+                                             InstalledPreference+                                             [OptionalStanza]  -- | Whether we prefer an installed version of a package or simply the latest -- version.@@ -199,28 +213,6 @@    | PreferLatestForSelected   deriving Show --- | Policy for relaxing upper bounds in dependencies. For example, given--- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper--- bound and choose a version of 'array' that is greater or equal to 0.5? By--- default the upper bounds are always strictly honored.-data AllowNewer =--  -- | Default: honor the upper bounds in all dependencies, never choose-  -- versions newer than allowed.-  AllowNewerNone--  -- | Ignore upper bounds in dependencies on the given packages.-  | AllowNewerSome [PackageName]--  -- | Ignore upper bounds in dependencies on all packages.-  | AllowNewerAll---- | Convert 'AllowNewer' to a boolean.-isAllowNewer :: AllowNewer -> Bool-isAllowNewer AllowNewerNone     = False-isAllowNewer (AllowNewerSome _) = True-isAllowNewer AllowNewerAll      = True- -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- result which may be used to indicate progress and\/or logging messages.@@ -245,7 +237,7 @@         fold (Done r)   = done r  instance Monad (Progress step fail) where-  return a = Done a+  return   = pure   p >>= f  = foldProgress Step Fail f p  instance Applicative (Progress step fail) where@@ -269,11 +261,14 @@   -- | Main config file, which is ~/.cabal/config by default.   ConstraintSourceMainConfig FilePath +  -- | Local cabal.project file+  | ConstraintSourceProjectConfig FilePath+   -- | Sandbox config file, which is ./cabal.sandbox.config by default.   | ConstraintSourceSandboxConfig FilePath -  -- | ./cabal.config.-  | ConstraintSourceUserConfig+  -- | User config file, which is ./cabal.config by default.+  | ConstraintSourceUserConfig FilePath    -- | Flag specified on the command line.   | ConstraintSourceCommandlineFlag@@ -298,15 +293,19 @@    -- | The source of the constraint is not specified.   | ConstraintSourceUnknown-  deriving (Eq, Show)+  deriving (Eq, Show, Generic) +instance Binary ConstraintSource+ -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String showConstraintSource (ConstraintSourceMainConfig path) =     "main config " ++ path+showConstraintSource (ConstraintSourceProjectConfig path) =+    "project config " ++ path showConstraintSource (ConstraintSourceSandboxConfig path) =     "sandbox config " ++ path-showConstraintSource ConstraintSourceUserConfig = "cabal.config"+showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" showConstraintSource ConstraintSourceUserTarget = "user target" showConstraintSource ConstraintSourceNonUpgradeablePackage =
+ cabal/cabal-install/Distribution/Client/DistDirLayout.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RecordWildCards #-}++-- | +--+-- The layout of the .\/dist\/ directory where cabal keeps all of it's state+-- and build artifacts.+--+module Distribution.Client.DistDirLayout where++import System.FilePath+import Distribution.Package+         ( PackageId )+import Distribution.Compiler+import Distribution.Simple.Compiler (PackageDB(..))+import Distribution.Text+import Distribution.Client.Types+         ( InstalledPackageId )++++-- | The layout of the project state directory. Traditionally this has been+-- called the @dist@ directory.+--+data DistDirLayout = DistDirLayout {++        -- | The dist directory, which is the root of where cabal keeps all its+       -- state including the build artifacts from each package we build.+       --+       distDirectory                :: FilePath,++       -- | The directory under dist where we keep the build artifacts for a+       -- package we're building from a local directory.+       --+       -- This uses a 'PackageId' not just a 'PackageName' because technically+       -- we can have multiple instances of the same package in a solution+       -- (e.g. setup deps).+       --+       distBuildDirectory           :: PackageId -> FilePath,+       distBuildRootDirectory       :: FilePath,++       -- | The directory under dist where we put the unpacked sources of+       -- packages, in those cases where it makes sense to keep the build+       -- artifacts to reduce rebuild times. These can be tarballs or could be+       -- scm repos.+       --+       distUnpackedSrcDirectory     :: PackageId -> FilePath,+       distUnpackedSrcRootDirectory :: FilePath,++       -- | The location for project-wide cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distProjectCacheFile         :: String -> FilePath,+       distProjectCacheDirectory    :: FilePath,++       -- | The location for package-specific cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distPackageCacheFile         :: PackageId -> String -> FilePath,+       distPackageCacheDirectory    :: PackageId -> FilePath,++       distTempDirectory            :: FilePath,+       distBinDirectory             :: FilePath,++       distPackageDB                :: CompilerId -> PackageDB+     }++++--TODO: move to another module, e.g. CabalDirLayout?+data CabalDirLayout = CabalDirLayout {+       cabalStoreDirectory        :: CompilerId -> FilePath,+       cabalStorePackageDirectory :: CompilerId -> InstalledPackageId+                                                -> FilePath,+       cabalStorePackageDBPath    :: CompilerId -> FilePath,+       cabalStorePackageDB        :: CompilerId -> PackageDB,++       cabalPackageCacheDirectory :: FilePath,+       cabalLogsDirectory         :: FilePath,+       cabalWorldFile             :: FilePath+     }+++defaultDistDirLayout :: FilePath -> DistDirLayout+defaultDistDirLayout projectRootDirectory =+    DistDirLayout {..}+  where+    distDirectory = projectRootDirectory </> "dist-newstyle"+    --TODO: switch to just dist at some point, or some other new name++    distBuildRootDirectory   = distDirectory </> "build"+    distBuildDirectory pkgid = distBuildRootDirectory </> display pkgid++    distUnpackedSrcRootDirectory   = distDirectory </> "src"+    distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory+                                      </> display pkgid++    distProjectCacheDirectory = distDirectory </> "cache"+    distProjectCacheFile name = distProjectCacheDirectory </> name++    distPackageCacheDirectory pkgid = distBuildDirectory pkgid </> "cache"+    distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid </> name++    distTempDirectory = distDirectory </> "tmp"++    distBinDirectory = distDirectory </> "bin"++    distPackageDBPath compid = distDirectory </> "packagedb" </> display compid+    distPackageDB = SpecificPackageDB . distPackageDBPath++++defaultCabalDirLayout :: FilePath -> CabalDirLayout+defaultCabalDirLayout cabalDir =+    CabalDirLayout {..}+  where++    cabalStoreDirectory compid =+      cabalDir </> "store" </> display compid++    cabalStorePackageDirectory compid ipkgid = +      cabalStoreDirectory compid </> display ipkgid++    cabalStorePackageDBPath compid =+      cabalStoreDirectory compid </> "package.db"++    cabalStorePackageDB =+      SpecificPackageDB . cabalStorePackageDBPath++    cabalPackageCacheDirectory = cabalDir </> "packages"++    cabalLogsDirectory = cabalDir </> "logs"++    cabalWorldFile = cabalDir </> "world"+
cabal/cabal-install/Distribution/Client/Exec.hs view
@@ -14,8 +14,6 @@  import Control.Monad (unless) -import Data.Foldable (forM_)- import qualified Distribution.Simple.GHC   as GHC import qualified Distribution.Simple.GHCJS as GHCJS @@ -65,7 +63,7 @@          [] -> die "Please specify an executable to run"   where-    environmentOverrides = +    environmentOverrides =         case useSandbox of             NoSandbox -> return []             (UseSandbox sandboxDir) ->@@ -91,21 +89,18 @@         let Just program = lookupProgram hcProgram programDb         gDb <- getGlobalPackageDB verbosity program         sandboxConfigFilePath <- getSandboxConfigFilePath mempty-        let compilerPackagePath = hcPackagePath gDb+        let sandboxPackagePath   = sandboxPackageDBPath sandboxDir comp platform+            compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath         -- Packages database must exist, otherwise things will start         -- failing in mysterious ways.-        forM_ compilerPackagePath $ \fp -> do-          exists <- doesDirectoryExist fp-          unless exists $ warn verbosity $ "Package database is not a directory: " ++ fp+        exists <- doesDirectoryExist sandboxPackagePath+        unless exists $ warn verbosity $ "Package database is not a directory: "+                                           ++ sandboxPackagePath         -- Build the environment-        return [ (packagePathEnvVar, compilerPackagePath)-               , ("CABAL_SANDBOX_PACKAGE_PATH", compilerPackagePath)+        return [ (packagePathEnvVar, Just compilerPackagePaths)+               , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)                , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)                ]--    hcPackagePath gDb =-        let s = sandboxPackageDBPath sandboxDir comp platform-            in Just $ prependToSearchPath gDb s      prependToSearchPath path newValue =         newValue ++ [searchPathSeparator] ++ path
cabal/cabal-install/Distribution/Client/Fetch.hs view
@@ -21,11 +21,11 @@ import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages )-import Distribution.Client.HttpUtils-         ( configureTransport, HttpTransport(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup-         ( GlobalFlags(..), FetchFlags(..) )+         ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )  import Distribution.Package          ( packageId )@@ -35,7 +35,7 @@ import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup-         ( fromFlag, flagToMaybe )+         ( fromFlag ) import Distribution.Simple.Utils          ( die, notice, debug ) import Distribution.System@@ -66,7 +66,7 @@ -- fetch :: Verbosity       -> PackageDBStack-      -> [Repo]+      -> RepoContext       -> Compiler       -> Platform       -> ProgramConfiguration@@ -77,24 +77,23 @@ fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repos comp platform conf+fetch verbosity packageDBs repoCtxt comp platform conf       globalFlags fetchFlags userTargets = do      mapM_ checkTarget userTargets      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos--    transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf -    pkgSpecifiers <- resolveUserTargets verbosity transport+    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)                        (packageIndex sourcePkgDb)                        userTargets      pkgs  <- planPackages                verbosity comp platform fetchFlags-               installedPkgIndex sourcePkgDb pkgSpecifiers+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers      pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs     if null pkgs'@@ -109,7 +108,7 @@                      "The following packages would be fetched:"                    : map (display . packageId) pkgs' -             else mapM_ (fetchPackage transport verbosity . packageSource) pkgs'+             else mapM_ (fetchPackage verbosity repoCtxt . packageSource) pkgs'    where     dryRun = fromFlag (fetchDryRun fetchFlags)@@ -120,10 +119,11 @@              -> FetchFlags              -> InstalledPackageIndex              -> SourcePackageDb-             -> [PackageSpecifier SourcePackage]-             -> IO [SourcePackage]+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> IO [UnresolvedSourcePackage] planPackages verbosity comp platform fetchFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers    | includeDependencies = do       solver <- chooseSolver verbosity@@ -131,15 +131,15 @@       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies-                         platform (compilerInfo comp)+                         platform (compilerInfo comp) pkgConfigDb                          solver                          resolverParams        -- The packages we want to fetch are those packages the 'InstallPlan'       -- that are in the 'InstallPlan.Configured' state.       return-        [ pkg-        | (InstallPlan.Configured (ConfiguredPackage pkg _ _ _))+        [ confPkgSource cpkg+        | (InstallPlan.Configured cpkg)             <- InstallPlan.toList installPlan ]    | otherwise =@@ -185,8 +185,8 @@             ++ "In the meantime you can use the 'unpack' commands."     _ -> return () -fetchPackage :: HttpTransport -> Verbosity -> PackageLocation a -> IO ()-fetchPackage transport verbosity pkgsrc = case pkgsrc of+fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()+fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of     LocalUnpackedPackage _dir  -> return ()     LocalTarballPackage  _file -> return () @@ -195,5 +195,5 @@          ++ "In the meantime you can use the 'unpack' commands."      RepoTarballPackage repo pkgid _ -> do-      _ <- fetchRepoTarball transport verbosity repo pkgid+      _ <- fetchRepoTarball verbosity repoCtxt repo pkgid       return ()
cabal/cabal-install/Distribution/Client/FetchUtils.hs view
@@ -11,6 +11,7 @@ -- -- Functions for fetching packages -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} module Distribution.Client.FetchUtils (      -- * fetching packages@@ -38,6 +39,8 @@          ( display ) import Distribution.Verbosity          ( Verbosity )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )  import Data.Maybe import System.Directory@@ -51,6 +54,8 @@ import Network.URI          ( URI(uriPath) ) +import qualified Hackage.Security.Client as Sec+ -- ------------------------------------------------------------ -- * Actually fetch things -- ------------------------------------------------------------@@ -58,7 +63,7 @@ -- | Returns @True@ if the package has already been fetched -- or does not need fetching. ---isFetched :: PackageLocation (Maybe FilePath) -> IO Bool+isFetched :: UnresolvedPkgLoc -> IO Bool isFetched loc = case loc of     LocalUnpackedPackage _dir       -> return True     LocalTarballPackage  _file      -> return True@@ -66,8 +71,8 @@     RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)  -checkFetched :: PackageLocation (Maybe FilePath)-             -> IO (Maybe (PackageLocation FilePath))+checkFetched :: UnresolvedPkgLoc+             -> IO (Maybe ResolvedPkgLoc) checkFetched loc = case loc of     LocalUnpackedPackage dir  ->       return (Just $ LocalUnpackedPackage dir)@@ -89,11 +94,11 @@  -- | Fetch a package if we don't have it already. ---fetchPackage :: HttpTransport-             -> Verbosity-             -> PackageLocation (Maybe FilePath)-             -> IO (PackageLocation FilePath)-fetchPackage transport verbosity loc = case loc of+fetchPackage :: Verbosity+             -> RepoContext+             -> UnresolvedPkgLoc+             -> IO ResolvedPkgLoc+fetchPackage verbosity repoCtxt loc = case loc of     LocalUnpackedPackage dir  ->       return (LocalUnpackedPackage dir)     LocalTarballPackage  file ->@@ -107,10 +112,11 @@       path <- downloadTarballPackage uri       return (RemoteTarballPackage uri path)     RepoTarballPackage repo pkgid Nothing -> do-      local <- fetchRepoTarball transport verbosity repo pkgid+      local <- fetchRepoTarball verbosity repoCtxt repo pkgid       return (RepoTarballPackage repo pkgid local)   where     downloadTarballPackage uri = do+      transport <- repoContextGetTransport repoCtxt       transportCheckHttps transport uri       notice verbosity ("Downloading " ++ show uri)       tmpdir <- getTemporaryDirectory@@ -122,8 +128,8 @@  -- | Fetch a repo package if we don't have it already. ---fetchRepoTarball :: HttpTransport -> Verbosity -> Repo -> PackageId -> IO FilePath-fetchRepoTarball transport verbosity repo pkgid = do+fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity repoCtxt repo pkgid = do   fetched <- doesFileExist (packageFile repo pkgid)   if fetched     then do info verbosity $ display pkgid ++ " has already been downloaded."@@ -131,16 +137,26 @@     else do setupMessage verbosity "Downloading" pkgid             downloadRepoPackage   where-    downloadRepoPackage = case repoKind repo of-      Right LocalRepo -> return (packageFile repo pkgid)+    downloadRepoPackage = case repo of+      RepoLocal{..} -> return (packageFile repo pkgid) -      Left remoteRepo -> do-        remoteRepoCheckHttps transport remoteRepo-        let uri  = packageURI remoteRepo pkgid-            dir  = packageDir       repo pkgid-            path = packageFile      repo pkgid+      RepoRemote{..} -> do+        transport <- repoContextGetTransport repoCtxt+        remoteRepoCheckHttps transport repoRemote+        let uri  = packageURI  repoRemote pkgid+            dir  = packageDir  repo       pkgid+            path = packageFile repo       pkgid         createDirectoryIfMissing True dir         _ <- downloadURI transport verbosity uri path+        return path++      RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do+        let dir  = packageDir  repo pkgid+            path = packageFile repo pkgid+        createDirectoryIfMissing True dir+        Sec.uncheckClientErrors $ do+          info verbosity ("writing " ++ path)+          Sec.downloadPackage' rep pkgid path         return path  -- | Downloads an index file to [config-dir/packages/serv-id].
+ cabal/cabal-install/Distribution/Client/FileMonitor.hs view
@@ -0,0 +1,1101 @@+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,+             NamedFieldPuns, BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | An abstraction to help with re-running actions when files or other+-- input values they depend on have changed.+--+module Distribution.Client.FileMonitor (++  -- * Declaring files to monitor+  MonitorFilePath(..),+  MonitorKindFile(..),+  MonitorKindDir(..),+  FilePathGlob(..),+  monitorFile,+  monitorFileHashed,+  monitorNonExistentFile,+  monitorDirectory,+  monitorDirectoryExistence,+  monitorFileOrDirectory,+  monitorFileGlob,+  monitorFileSearchPath,+  monitorFileHashedSearchPath,++  -- * Creating and checking sets of monitored files+  FileMonitor(..),+  newFileMonitor,+  MonitorChanged(..),+  MonitorChangedReason(..),+  checkFileMonitorChanged,+  updateFileMonitor,+  MonitorTimestamp,+  beginUpdateFileMonitor,+  ) where+++#if MIN_VERSION_containers(0,5,0)+import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+#else+import           Data.Map        (Map)+import qualified Data.Map        as Map+#endif+import qualified Data.ByteString.Lazy as BS+import           Distribution.Compat.Binary+import qualified Distribution.Compat.Binary as Binary+import qualified Data.Hashable as Hashable+import           Data.List (sort)++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+import           Control.Monad+import           Control.Monad.Trans (MonadIO, liftIO)+import           Control.Monad.State (StateT, mapStateT)+import qualified Control.Monad.State as State+import           Control.Monad.Except (ExceptT, runExceptT, withExceptT,+                                       throwError)+import           Control.Exception++import           Distribution.Client.Compat.Time+import           Distribution.Client.Glob+import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)+import           Distribution.Client.Utils (mergeBy, MergeResult(..))++import           System.FilePath+import           System.Directory+import           System.IO+import           GHC.Generics (Generic)+++------------------------------------------------------------------------------+-- Types for specifying files to monitor+--+++-- | A description of a file (or set of files) to monitor for changes.+--+-- Where file paths are relative they are relative to a common directory+-- (e.g. project root), not necessarily the process current directory.+--+data MonitorFilePath =+     MonitorFile {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPath     :: !FilePath+     }+   | MonitorFileGlob {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPathGlob :: !FilePathGlob+     }+  deriving (Eq, Show, Generic)++data MonitorKindFile = FileExists+                     | FileModTime+                     | FileHashed+                     | FileNotExists+  deriving (Eq, Show, Generic)++data MonitorKindDir  = DirExists+                     | DirModTime+                     | DirNotExists+  deriving (Eq, Show, Generic)++instance Binary MonitorFilePath+instance Binary MonitorKindFile+instance Binary MonitorKindDir++-- | Monitor a single file for changes, based on its modification time.+-- The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFile :: FilePath -> MonitorFilePath+monitorFile = MonitorFile FileModTime DirNotExists++-- | Monitor a single file for changes, based on its modification time+-- and content hash. The monitored file is considered to have changed if+-- it no longer exists or if its modification time and content hash have+-- changed.+--+monitorFileHashed :: FilePath -> MonitorFilePath+monitorFileHashed = MonitorFile FileHashed DirNotExists++-- | Monitor a single non-existent file for changes. The monitored file+-- is considered to have changed if it exists.+--+monitorNonExistentFile :: FilePath -> MonitorFilePath+monitorNonExistentFile = MonitorFile FileNotExists DirNotExists++-- | Monitor a single directory for changes, based on its modification+-- time. The monitored directory is considered to have changed if it no+-- longer exists or if its modification time has changed.+--+monitorDirectory :: FilePath -> MonitorFilePath+monitorDirectory = MonitorFile FileNotExists DirModTime++-- | Monitor a single directory for existence. The monitored directory is+-- considered to have changed only if it no longer exists.+--+monitorDirectoryExistence :: FilePath -> MonitorFilePath+monitorDirectoryExistence = MonitorFile FileNotExists DirExists++-- | Monitor a single file or directory for changes, based on its modification+-- time. The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFileOrDirectory :: FilePath -> MonitorFilePath+monitorFileOrDirectory = MonitorFile FileModTime DirModTime++-- | Monitor a set of files (or directories) identified by a file glob.+-- The monitored glob is considered to have changed if the set of files+-- matching the glob changes (i.e. creations or deletions), or for files if the+-- modification time and content hash of any matching file has changed.+--+monitorFileGlob :: FilePathGlob -> MonitorFilePath+monitorFileGlob = MonitorFileGlob FileHashed DirExists++-- | Creates a list of files to monitor when you search for a file which+-- unsuccessfully looked in @notFoundAtPaths@ before finding it at+-- @foundAtPath@.+monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileSearchPath notFoundAtPaths foundAtPath =+    monitorFile foundAtPath+  : map monitorNonExistentFile notFoundAtPaths++-- | Similar to 'monitorFileSearchPath', but also instructs us to+-- monitor the hash of the found file.+monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileHashedSearchPath notFoundAtPaths foundAtPath =+    monitorFileHashed foundAtPath+  : map monitorNonExistentFile notFoundAtPaths+++------------------------------------------------------------------------------+-- Implementation types, files status+--++-- | The state necessary to determine whether a set of monitored+-- files has changed.  It consists of two parts: a set of specific+-- files to be monitored (index by their path), and a list of+-- globs, which monitor may files at once.+data MonitorStateFileSet+   = MonitorStateFileSet !(Map FilePath MonitorStateFile)+                         ![MonitorStateGlob]+  deriving Show++type Hash = Int++-- | The state necessary to determine whether a monitored file has changed.+--+-- This covers all the cases of 'MonitorFilePath' except for globs which is+-- covered separately by 'MonitorStateGlob'.+--+-- The @Maybe ModTime@ is to cover the case where we already consider the+-- file to have changed, either because it had already changed by the time we+-- did the snapshot (i.e. too new, changed since start of update process) or it+-- no longer exists at all.+--+data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir+                                         !MonitorStateFileStatus+  deriving (Show, Generic)++data MonitorStateFileStatus+   = MonitorStateFileExists+   | MonitorStateFileModTime !ModTime        -- ^ cached file mtime+   | MonitorStateFileHashed  !ModTime !Hash  -- ^ cached mtime and content hash+   | MonitorStateDirExists+   | MonitorStateDirModTime  !ModTime        -- ^ cached dir mtime+   | MonitorStateNonExistent+   | MonitorStateAlreadyChanged+  deriving (Show, Generic)++instance Binary MonitorStateFile+instance Binary MonitorStateFileStatus++-- | The state necessary to determine whether the files matched by a globbing+-- match have changed.+--+data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir+                                         !FilePathRoot !MonitorStateGlobRel+  deriving (Show, Generic)++data MonitorStateGlobRel+   = MonitorStateGlobDirs+       !Glob !FilePathGlobRel+       !ModTime+       ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted++   | MonitorStateGlobFiles+       !Glob+       !ModTime+       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted++   | MonitorStateGlobDirTrailing+  deriving (Show, Generic)++instance Binary MonitorStateGlob+instance Binary MonitorStateGlobRel++-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by+-- inspecting the state of the file system, and we can go in the reverse+-- direction by just forgetting the extra info.+--+reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]+reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =+    Map.foldrWithKey (\k x r -> getSinglePath k x : r)+                     (map getGlobPath globPaths)+                     singlePaths+  where+    getSinglePath filepath (MonitorStateFile kindfile kinddir _) =+      MonitorFile kindfile kinddir filepath++    getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =+      MonitorFileGlob kindfile kinddir $ FilePathGlob root $+        case gstate of+          MonitorStateGlobDirs  glob globs _ _ -> GlobDir  glob globs+          MonitorStateGlobFiles glob       _ _ -> GlobFile glob+          MonitorStateGlobDirTrailing          -> GlobDirTrailing++------------------------------------------------------------------------------+-- Checking the status of monitored files+--++-- | A monitor for detecting changes to a set of files. It can be used to+-- efficiently test if any of a set of files (specified individually or by+-- glob patterns) has changed since some snapshot. In addition, it also checks+-- for changes in a value (of type @a@), and when there are no changes in+-- either it returns a saved value (of type @b@).+--+-- The main use case looks like this: suppose we have some expensive action+-- that depends on certain pure inputs and reads some set of files, and+-- produces some pure result. We want to avoid re-running this action when it+-- would produce the same result. So we need to monitor the files the action+-- looked at, the other pure input values, and we need to cache the result.+-- Then at some later point, if the input value didn't change, and none of the+-- files changed, then we can re-use the cached result rather than re-running+-- the action.+--+-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance+-- saves state in a disk file, so the file for that has to be specified,+-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged'+-- to see if there's been any change. If there is, re-run the action, keeping+-- track of the files, then use 'updateFileMonitor' to record the current+-- set of files to monitor, the current input value for the action, and the+-- result of the action.+--+-- The typical occurrence of this pattern is captured by 'rerunIfChanged'+-- and the 'Rebuild' monad. More complicated cases may need to use+-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly.+--+data FileMonitor a b+   = FileMonitor {++       -- | The file where this 'FileMonitor' should store its state.+       --+       fileMonitorCacheFile :: FilePath,++       -- | Compares a new cache key with old one to determine if a+       -- corresponding cached value is still valid.+       --+       -- Typically this is just an equality test, but in some+       -- circumstances it can make sense to do things like subset+       -- comparisons.+       --+       -- The first arg is the new value, the second is the old cached value.+       --+       fileMonitorKeyValid :: a -> a -> Bool,++       -- | When this mode is enabled, if 'checkFileMonitorChanged' returns+       -- 'MonitoredValueChanged' then we have the guarantee that no files+       -- changed, that the value change was the only change. In the default+       -- mode no such guarantee is provided which is slightly faster.+       --+       fileMonitorCheckIfOnlyValueChanged :: Bool+  }++-- | Define a new file monitor.+--+-- It's best practice to define file monitor values once, and then use the+-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this+-- ensures you get the same types @a@ and @b@ for reading and writing.+--+-- The path of the file monitor itself must be unique because it keeps state+-- on disk and these would clash.+--+newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the+                                   -- file monitor. Must be unique.+                       -> FileMonitor a b+newFileMonitor path = FileMonitor path (==) False++-- | The result of 'checkFileMonitorChanged': either the monitored files or+-- value changed (and it tells us which it was) or nothing changed and we get+-- the cached result.+--+data MonitorChanged a b =+     -- | The monitored files and value did not change. The cached result is+     -- @b@.+     --+     -- The set of monitored files is also returned. This is useful+     -- for composing or nesting 'FileMonitor's.+     MonitorUnchanged b [MonitorFilePath]++     -- | The monitor found that something changed. The reason is given.+     --+   | MonitorChanged (MonitorChangedReason a)+  deriving Show++-- | What kind of change 'checkFileMonitorChanged' detected.+--+data MonitorChangedReason a =++     -- | One of the files changed (existence, file type, mtime or file+     -- content, depending on the 'MonitorFilePath' in question)+     MonitoredFileChanged FilePath++     -- | The pure input value changed.+     --+     -- The previous cached key value is also returned. This is sometimes+     -- useful when using a 'fileMonitorKeyValid' function that is not simply+     -- '(==)', when invalidation can be partial. In such cases it can make+     -- sense to 'updateFileMonitor' with a key value that's a combination of+     -- the new and old (e.g. set union).+   | MonitoredValueChanged a++     -- | There was no saved monitor state, cached value etc. Ie the file+     -- for the 'FileMonitor' does not exist.+   | MonitorFirstRun++     -- | There was existing state, but we could not read it. This typically+     -- happens when the code has changed compared to an existing 'FileMonitor'+     -- cache file and type of the input value or cached value has changed such+     -- that we cannot decode the values. This is completely benign as we can+     -- treat is just as if there were no cache file and re-run.+   | MonitorCorruptCache+  deriving (Eq, Show, Functor)++-- | Test if the input value or files monitored by the 'FileMonitor' have+-- changed. If not, return the cached value.+--+-- See 'FileMonitor' for a full explanation.+--+checkFileMonitorChanged+  :: (Binary a, Binary b)+  => FileMonitor a b            -- ^ cache file path+  -> FilePath                   -- ^ root directory+  -> a                          -- ^ guard or key value+  -> IO (MonitorChanged a b)    -- ^ did the key or any paths change?+checkFileMonitorChanged+    monitor@FileMonitor { fileMonitorKeyValid,+                          fileMonitorCheckIfOnlyValueChanged }+    root currentKey =++    -- Consider it a change if the cache file does not exist,+    -- or we cannot decode it. Sadly ErrorCall can still happen, despite+    -- using decodeFileOrFail, e.g. Data.Char.chr errors++    handleDoesNotExist (MonitorChanged MonitorFirstRun) $+    handleErrorCall    (MonitorChanged MonitorCorruptCache) $+          readCacheFile monitor+      >>= either (\_ -> return (MonitorChanged MonitorCorruptCache))+                 checkStatusCache++  where+    checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do+        change <- checkForChanges+        case change of+          Just reason -> return (MonitorChanged reason)+          Nothing     -> return (MonitorUnchanged cachedResult monitorFiles)+            where monitorFiles = reconstructMonitorFilePaths cachedFileStatus+      where+        -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that+        -- if we return MonitoredValueChanged that only the value changed.+        -- We do that by checkin for file changes first. Otherwise it makes+        -- more sense to do the cheaper test first.+        checkForChanges+          | fileMonitorCheckIfOnlyValueChanged+          = checkFileChange cachedFileStatus cachedKey cachedResult+              `mplusMaybeT`+            checkValueChange cachedKey++          | otherwise+          = checkValueChange cachedKey+              `mplusMaybeT`+            checkFileChange cachedFileStatus cachedKey cachedResult++    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    mplusMaybeT ma mb = do+      mx <- ma+      case mx of+        Nothing -> mb+        Just x  -> return (Just x)++    -- Check if the guard value has changed+    checkValueChange cachedKey+      | not (fileMonitorKeyValid currentKey cachedKey)+      = return (Just (MonitoredValueChanged cachedKey))+      | otherwise+      = return Nothing++    -- Check if any file has changed+    checkFileChange cachedFileStatus cachedKey cachedResult = do+      res <- probeFileSystem root cachedFileStatus+      case res of+        -- Some monitored file has changed+        Left changedPath ->+          return (Just (MonitoredFileChanged (normalise changedPath)))++        -- No monitored file has changed+        Right (cachedFileStatus', cacheStatus) -> do++          -- But we might still want to update the cache+          whenCacheChanged cacheStatus $+            rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult++          return Nothing++-- | Helper for reading the cache file.+--+-- This determines the type and format of the binary cache file.+--+readCacheFile :: (Binary a, Binary b)+              => FileMonitor a b+              -> IO (Either String (MonitorStateFileSet, a, b))+readCacheFile FileMonitor {fileMonitorCacheFile} =+    withBinaryFile fileMonitorCacheFile ReadMode $ \hnd ->+      Binary.decodeOrFailIO =<< BS.hGetContents hnd++-- | Helper for writing the cache file.+--+-- This determines the type and format of the binary cache file.+--+rewriteCacheFile :: (Binary a, Binary b)+                 => FileMonitor a b+                 -> MonitorStateFileSet -> a -> b -> IO ()+rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =+    writeFileAtomic fileMonitorCacheFile $+      Binary.encode (fileset, key, result)++-- | Probe the file system to see if any of the monitored files have changed.+--+-- It returns Nothing if any file changed, or returns a possibly updated+-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed.+--+-- We may need to update the cache since there may be changes in the filesystem+-- state which don't change any of our affected files.+--+-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a+-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run+-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then+-- we want to update the cache despite no changes in our relevant file set.+-- Specifically, we should add an mtime for this directory so we can avoid+-- re-traversing the directory in future runs.+--+probeFileSystem :: FilePath -> MonitorStateFileSet+                -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))+probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =+  runChangedM $ do+    sequence_+      [ probeMonitorStateFileStatus root file status+      | (file, MonitorStateFile _ _ status) <- Map.toList singlePaths ]+    -- The glob monitors can require state changes+    globPaths' <-+      sequence+        [ probeMonitorStateGlob root globPath+        | globPath <- globPaths ]+    return (MonitorStateFileSet singlePaths globPaths')+++-----------------------------------------------+-- Monad for checking for file system changes+--+-- We need to be able to bail out if we detect a change (using ExceptT),+-- but if there's no change we need to be able to rebuild the monitor+-- state. And we want to optimise that rebuilding by keeping track if+-- anything actually changed (using StateT), so that in the typical case+-- we can avoid rewriting the state file.++newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged))+runChangedM (ChangedM action) =+  runExceptT $ State.runStateT action CacheUnchanged++somethingChanged :: FilePath -> ChangedM a+somethingChanged path = ChangedM $ throwError path++cacheChanged :: ChangedM ()+cacheChanged = ChangedM $ State.put CacheChanged++mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a+mapChangedFile adjust (ChangedM a) =+    ChangedM (mapStateT (withExceptT adjust) a)++data CacheChanged = CacheChanged | CacheUnchanged++whenCacheChanged :: Monad m => CacheChanged -> m () -> m ()+whenCacheChanged CacheChanged action = action+whenCacheChanged CacheUnchanged _    = return ()++----------------------++-- | Probe the file system to see if a single monitored file has changed.+--+probeMonitorStateFileStatus :: FilePath -> FilePath+                            -> MonitorStateFileStatus+                            -> ChangedM ()+probeMonitorStateFileStatus root file status =+    case status of+      MonitorStateFileExists ->+        probeFileExistence root file++      MonitorStateFileModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateFileHashed  mtime hash ->+        probeFileModificationTimeAndHash root file mtime hash++      MonitorStateDirExists ->+        probeDirExistence root file++      MonitorStateDirModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateNonExistent ->+        probeFileNonExistence root file++      MonitorStateAlreadyChanged ->+        somethingChanged file+++-- | Probe the file system to see if a monitored file glob has changed.+--+probeMonitorStateGlob :: FilePath      -- ^ root path+                      -> MonitorStateGlob+                      -> ChangedM MonitorStateGlob+probeMonitorStateGlob relroot+                      (MonitorStateGlob kindfile kinddir globroot glob) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    case globroot of+      FilePathRelative ->+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "." glob++      -- for absolute cases, make the changed file we report absolute too+      _ ->+        mapChangedFile (root </>) $+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "" glob++probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir+                         -> FilePath      -- ^ root path+                         -> FilePath      -- ^ path of the directory we are+                                          --   looking in relative to @root@+                         -> MonitorStateGlobRel+                         -> ChangedM MonitorStateGlobRel+probeMonitorStateGlobRel kindfile kinddir root dirName+                        (MonitorStateGlobDirs glob globPath mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    case change of+      Nothing -> do+        children' <- sequence+          [ do fstate' <- probeMonitorStateGlobRel+                            kindfile kinddir root+                            (dirName </> fname) fstate+               return (fname, fstate')+          | (fname, fstate) <- children ]+        return $! MonitorStateGlobDirs glob globPath mtime children'++      Just mtime' -> do+        -- directory modification time changed:+        -- a matching subdir may have been added or deleted+        matches <- filterM (\entry -> let subdir = root </> dirName </> entry+                                       in liftIO $ doesDirectoryExist subdir)+                 . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        children' <- mapM probeMergeResult $+                          mergeBy (\(path1,_) path2 -> compare path1 path2)+                                  children+                                  (sort matches)+        return $! MonitorStateGlobDirs glob globPath mtime' children'+        -- Note that just because the directory has changed, we don't force+        -- a cache rewrite with 'cacheChanged' since that has some cost, and+        -- all we're saving is scanning the directory. But we do rebuild the+        -- cache with the new mtime', so that if the cache is rewritten for+        -- some other reason, we'll take advantage of that.++  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath+                     -> ChangedM (FilePath, MonitorStateGlobRel)++    -- Only in cached (directory deleted)+    probeMergeResult (OnlyInLeft (path, fstate)) = do+      case allMatchingFiles (dirName </> path) fstate of+        [] -> return (path, fstate)+        -- Strictly speaking we should be returning 'CacheChanged' above+        -- as we should prune the now-missing 'MonitorStateGlobRel'. However+        -- we currently just leave these now-redundant entries in the+        -- cache as they cost no IO and keeping them allows us to avoid+        -- rewriting the cache.+        (file:_) -> somethingChanged file++    -- Only in current filesystem state (directory added)+    probeMergeResult (OnlyInRight path) = do+      fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty+                           kindfile kinddir root (dirName </> path) globPath+      case allMatchingFiles (dirName </> path) fstate of+        (file:_) -> somethingChanged file+        -- This is the only case where we use 'cacheChanged' because we can+        -- have a whole new dir subtree (of unbounded size and cost), so we+        -- need to save the state of that new subtree in the cache.+        [] -> cacheChanged >> return (path, fstate)++    -- Found in path+    probeMergeResult (InBoth (path, fstate) _) = do+      fstate' <- probeMonitorStateGlobRel kindfile kinddir+                                          root (dirName </> path) fstate+      return (path, fstate')++    -- | Does a 'MonitorStateGlob' have any relevant files within it?+    allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]+    allMatchingFiles dir (MonitorStateGlobFiles _ _   entries) =+      [ dir </> fname | (fname, _) <- entries ]+    allMatchingFiles dir (MonitorStateGlobDirs  _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- allMatchingFiles (dir </> subdir) fstate ]+    allMatchingFiles dir MonitorStateGlobDirTrailing =+      [dir]++probeMonitorStateGlobRel _ _ root dirName+                         (MonitorStateGlobFiles glob mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    mtime' <- case change of+      Nothing     -> return mtime+      Just mtime' -> do+        -- directory modification time changed:+        -- a matching file may have been added or deleted+        matches <- return . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        mapM_ probeMergeResult $+              mergeBy (\(path1,_) path2 -> compare path1 path2)+                      children+                      (sort matches)+        return mtime'++    -- Check that none of the children have changed+    forM_ children $ \(file, status) ->+      probeMonitorStateFileStatus root (dirName </> file) status+++    return (MonitorStateGlobFiles glob mtime' children)+    -- Again, we don't force a cache rewite with 'cacheChanged', but we do use+    -- the new mtime' if any.+  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath+                     -> ChangedM ()+    probeMergeResult mr = case mr of+      InBoth _ _            -> return ()+    -- this is just to be able to accurately report which file changed:+      OnlyInLeft  (path, _) -> somethingChanged (dirName </> path)+      OnlyInRight path      -> somethingChanged (dirName </> path)++probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =+    return MonitorStateGlobDirTrailing++------------------------------------------------------------------------------++-- | Update the input value and the set of files monitored by the+-- 'FileMonitor', plus the cached value that may be returned in future.+--+-- This takes a snapshot of the state of the monitored files right now, so+-- 'checkFileMonitorChanged' will look for file system changes relative to+-- this snapshot.+--+-- This is typically done once the action has been completed successfully and+-- we have the action's result and we know what files it looked at. See+-- 'FileMonitor' for a full explanation.+--+-- If we do take the snapshot after the action has completed then we have a+-- problem. The problem is that files might have changed /while/ the action was+-- running but /after/ the action read them. If we take the snapshot after the+-- action completes then we will miss these changes. The solution is to record+-- a timestamp before beginning execution of the action and then we make the+-- conservative assumption that any file that has changed since then has+-- already changed, ie the file monitor state for these files will be such that+-- 'checkFileMonitorChanged' will report that they have changed.+--+-- So if you do use 'updateFileMonitor' after the action (so you can discover+-- the files used rather than predicting them in advance) then use+-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively,+-- if you take the snapshot in advance of the action, or you're not monitoring+-- any files then you can use @Nothing@ for the timestamp parameter.+--+updateFileMonitor+  :: (Binary a, Binary b)+  => FileMonitor a b          -- ^ cache file path+  -> FilePath                 -- ^ root directory+  -> Maybe MonitorTimestamp   -- ^ timestamp when the update action started+  -> [MonitorFilePath]        -- ^ files of interest relative to root+  -> a                        -- ^ the current key value+  -> b                        -- ^ the current result value+  -> IO ()+updateFileMonitor monitor root startTime monitorFiles+                  cachedKey cachedResult = do+    hashcache <- readCacheFileHashes monitor+    msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles+    rewriteCacheFile monitor msfs cachedKey cachedResult++-- | A timestamp to help with the problem of file changes during actions.+-- See 'updateFileMonitor' for details.+--+newtype MonitorTimestamp = MonitorTimestamp ModTime++-- | Record a timestamp at the beginning of an action, and when the action+-- completes call 'updateFileMonitor' passing it the timestamp.+-- See 'updateFileMonitor' for details.+--+beginUpdateFileMonitor :: IO MonitorTimestamp+beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime++-- | Take the snapshot of the monitored files. That is, given the+-- specification of the set of files we need to monitor, inspect the state+-- of the file system now and collect the information we'll need later to+-- determine if anything has changed.+--+buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp+                                              -- of the start of the action+                         -> FileHashCache     -- ^ existing file hashes+                         -> FilePath          -- ^ root directory+                         -> [MonitorFilePath] -- ^ patterns of interest+                                              --   relative to root+                         -> IO MonitorStateFileSet+buildMonitorStateFileSet mstartTime hashcache root =+    go Map.empty []+  where+    go :: Map FilePath MonitorStateFile -> [MonitorStateGlob]+       -> [MonitorFilePath] -> IO MonitorStateFileSet+    go !singlePaths !globPaths [] =+      return (MonitorStateFileSet singlePaths globPaths)++    go !singlePaths !globPaths+       (MonitorFile kindfile kinddir path : monitors) = do+      monitorState <- MonitorStateFile kindfile kinddir+                  <$> buildMonitorStateFile mstartTime hashcache+                                            kindfile kinddir root path+      go (Map.insert path monitorState singlePaths) globPaths monitors++    go !singlePaths !globPaths+       (MonitorFileGlob kindfile kinddir globPath : monitors) = do+      monitorState <- buildMonitorStateGlob mstartTime hashcache+                                            kindfile kinddir root globPath+      go singlePaths (monitorState : globPaths) monitors+++buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache          -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath               -- ^ the root directory+                      -> FilePath+                      -> IO MonitorStateFileStatus+buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do+    let abspath = root </> path+    isFile <- doesFileExist abspath+    isDir  <- doesDirectoryExist abspath+    case (isFile, kindfile, isDir, kinddir) of+      (_, FileNotExists, _, DirNotExists) ->+        -- we don't need to care if it exists now, since we check at probe time+        return MonitorStateNonExistent++      (False, _, False, _) ->+        return MonitorStateAlreadyChanged++      (True, FileExists, _, _)  ->+        return MonitorStateFileExists++      (True, FileModTime, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateFileModTime mtime)++      (True, FileHashed, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else do hash <- getFileHash hashcache abspath abspath mtime+                    return (MonitorStateFileHashed mtime hash)++      (_, _, True, DirExists) ->+        return MonitorStateDirExists++      (_, _, True, DirModTime) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateDirModTime mtime)++      (False, _, True,  DirNotExists) -> return MonitorStateAlreadyChanged+      (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged++-- | If we have a timestamp for the beginning of the update, then any file+-- mtime later than this means that it changed during the update and we ought+-- to consider the file as already changed.+--+changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool+changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime+                        = mtime > startTime+changedDuringUpdate _ _ = False++-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case+-- of a file glob.+--+-- This gets used both by 'buildMonitorStateFileSet' when we're taking the+-- file system snapshot, but also by 'probeGlobStatus' as part of checking+-- the monitored (globed) files for changes when we find a whole new subtree.+--+buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache     -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath     -- ^ the root directory+                      -> FilePathGlob -- ^ the matching glob+                      -> IO MonitorStateGlob+buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot+                      (FilePathGlob globroot globPath) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    MonitorStateGlob kindfile kinddir globroot <$>+      buildMonitorStateGlobRel+        mstartTime hashcache kindfile kinddir root "." globPath++buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update+                         -> FileHashCache   -- ^ existing file hashes+                         -> MonitorKindFile -> MonitorKindDir+                         -> FilePath        -- ^ the root directory+                         -> FilePath        -- ^ directory we are examining+                                            --   relative to the root+                         -> FilePathGlobRel -- ^ the matching glob+                         -> IO MonitorStateGlobRel+buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root+                         dir globPath = do+    let absdir = root </> dir+    dirEntries <- getDirectoryContents absdir+    dirMTime   <- getModTime absdir+    case globPath of+      GlobDir glob globPath' -> do+        subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))+                 $ filter (matchGlob glob) dirEntries+        subdirStates <-+          forM (sort subdirs) $ \subdir -> do+            fstate <- buildMonitorStateGlobRel+                        mstartTime hashcache kindfile kinddir root+                        (dir </> subdir) globPath'+            return (subdir, fstate)+        return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates++      GlobFile glob -> do+        let files = filter (matchGlob glob) dirEntries+        filesStates <-+          forM (sort files) $ \file -> do+            fstate <- buildMonitorStateFile+                        mstartTime hashcache kindfile kinddir root+                        (dir </> file)+            return (file, fstate)+        return $! MonitorStateGlobFiles glob dirMTime filesStates++      GlobDirTrailing ->+        return MonitorStateGlobDirTrailing+++-- | We really want to avoid re-hashing files all the time. We already make+-- the assumption that if a file mtime has not changed then we don't need to+-- bother checking if the content hash has changed. We can apply the same+-- assumption when updating the file monitor state. In the typical case of+-- updating a file monitor the set of files is the same or largely the same so+-- we can grab the previously known content hashes with their corresponding+-- mtimes.+--+type FileHashCache = Map FilePath (ModTime, Hash)++-- | We declare it a cache hit if the mtime of a file is the same as before.+--+lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash+lookupFileHashCache hashcache file mtime = do+    (mtime', hash) <- Map.lookup file hashcache+    guard (mtime' == mtime)+    return hash++-- | Either get it from the cache or go read the file+getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash+getFileHash hashcache relfile absfile mtime =+    case lookupFileHashCache hashcache relfile mtime of+      Just hash -> return hash+      Nothing   -> readFileHash absfile++-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While+-- in principle we could preserve the structure of the previous state, given+-- that the set of files to monitor can change then it's simpler just to throw+-- away the structure and use a finite map.+--+readCacheFileHashes :: (Binary a, Binary b)+                    => FileMonitor a b -> IO FileHashCache+readCacheFileHashes monitor =+    handleDoesNotExist Map.empty $+    handleErrorCall    Map.empty $ do+      res <- readCacheFile monitor+      case res of+        Left _             -> return Map.empty+        Right (msfs, _, _) -> return (mkFileHashCache msfs)+  where+    mkFileHashCache :: MonitorStateFileSet -> FileHashCache+    mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =+                    collectAllFileHashes singlePaths+        `Map.union` collectAllGlobHashes globPaths++    collectAllFileHashes =+      Map.mapMaybe $ \(MonitorStateFile _ _ fstate) -> case fstate of+        MonitorStateFileHashed mtime hash -> Just (mtime, hash)+        _                                 -> Nothing++    collectAllGlobHashes globPaths =+      Map.fromList [ (fpath, hash)+                   | MonitorStateGlob _ _ _ gstate <- globPaths+                   , (fpath, hash) <- collectGlobHashes "" gstate ]++    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- collectGlobHashes (dir </> subdir) fstate ]++    collectGlobHashes dir (MonitorStateGlobFiles  _ _ entries) =+      [ (dir </> fname, (mtime, hash))+      | (fname, MonitorStateFileHashed mtime hash) <- entries ]++    collectGlobHashes _dir MonitorStateGlobDirTrailing =+      []+++------------------------------------------------------------------------------+-- Utils+--++-- | Within the @root@ directory, check if @file@ has its 'ModTime' is+-- the same as @mtime@, short-circuiting if it is different.+probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM ()+probeFileModificationTime root file mtime = do+    unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ has its 'ModTime' and+-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is+-- different.+probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash+                                 -> ChangedM ()+probeFileModificationTimeAndHash root file mtime hash = do+    unchanged <- liftIO $+      checkFileModificationTimeAndHashUnchanged root file mtime hash+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ still exists as a file.+-- If it *does not* exist, short-circuit.+probeFileExistence :: FilePath -> FilePath -> ChangedM ()+probeFileExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    unless existsFile (somethingChanged file)++-- | Within the @root@ directory, check if @dir@ still exists.+-- If it *does not* exist, short-circuit.+probeDirExistence :: FilePath -> FilePath -> ChangedM ()+probeDirExistence root dir = do+    existsDir  <- liftIO $ doesDirectoryExist (root </> dir)+    unless existsDir (somethingChanged dir)++-- | Within the @root@ directory, check if @file@ still does not exist.+-- If it *does* exist, short-circuit.+probeFileNonExistence :: FilePath -> FilePath -> ChangedM ()+probeFileNonExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    existsDir  <- liftIO $ doesDirectoryExist (root </> file)+    when (existsFile || existsDir) (somethingChanged file)++-- | Returns @True@ if, inside the @root@ directory, @file@ has the same+-- 'ModTime' as @mtime@.+checkModificationTimeUnchanged :: FilePath -> FilePath+                               -> ModTime -> IO Bool+checkModificationTimeUnchanged root file mtime =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    return (mtime == mtime')++-- | Returns @True@ if, inside the @root@ directory, @file@ has the+-- same 'ModTime' and 'Hash' as @mtime and @chash@.+checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath+                                          -> ModTime -> Hash -> IO Bool+checkFileModificationTimeAndHashUnchanged root file mtime chash =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    if mtime == mtime'+      then return True+      else do+        chash' <- readFileHash (root </> file)+        return (chash == chash')++-- | Read a non-cryptographic hash of a @file@.+readFileHash :: FilePath -> IO Hash+readFileHash file =+    withBinaryFile file ReadMode $ \hnd ->+      evaluate . Hashable.hash =<< BS.hGetContents hnd++-- | Given a directory @dir@, return @Nothing@ if its 'ModTime'+-- is the same as @mtime@, and the new 'ModTime' if it is not.+checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime)+checkDirectoryModificationTime dir mtime =+  handleIOException Nothing $ do+    mtime' <- getModTime dir+    if mtime == mtime'+      then return Nothing+      else return (Just mtime')++-- | Run an IO computation, returning @e@ if there is an 'error'+-- call. ('ErrorCall')+handleErrorCall :: a -> IO a -> IO a+handleErrorCall e =+    handle (\(ErrorCall _) -> return e)++-- | Run an IO computation, returning @e@ if there is any 'IOException'.+--+-- This policy is OK in the file monitor code because it just causes the+-- monitor to report that something changed, and then code reacting to that+-- will normally encounter the same IO exception when it re-runs the action+-- that uses the file.+--+handleIOException :: a -> IO a -> IO a+handleIOException e =+    handle (anyIOException e)+  where+    anyIOException :: a -> IOException -> IO a+    anyIOException x _ = return x+++------------------------------------------------------------------------------+-- Instances+--++instance Binary MonitorStateFileSet where+  put (MonitorStateFileSet singlePaths globPaths) = do+    put (1 :: Int) -- version+    put singlePaths+    put globPaths+  get = do+    ver <- get+    if ver == (1 :: Int)+      then do singlePaths <- get+              globPaths   <- get+              return $! MonitorStateFileSet singlePaths globPaths+      else fail "MonitorStateFileSet: wrong version"
cabal/cabal-install/Distribution/Client/Freeze.hs view
@@ -13,7 +13,7 @@ -- The cabal freeze command ----------------------------------------------------------------------------- module Distribution.Client.Freeze (-    freeze,+    freeze, getFreezePkgs   ) where  import Distribution.Client.Config ( SavedConfig(..) )@@ -27,10 +27,11 @@ import Distribution.Client.InstallPlan          ( InstallPlan, PlanPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.Client.Setup-         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )-import Distribution.Client.HttpUtils-         ( configureTransport )+         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)+         , RepoContext(..) ) import Distribution.Client.Sandbox.PackageEnvironment          ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,            userPackageEnvironmentFile )@@ -42,7 +43,6 @@ import Distribution.Simple.Compiler          ( Compiler, compilerInfo, PackageDBStack ) import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.Program          ( ProgramConfiguration ) import Distribution.Simple.Setup@@ -77,7 +77,7 @@ -- freeze :: Verbosity       -> PackageDBStack-      -> [Repo]+      -> RepoContext       -> Compiler       -> Platform       -> ProgramConfiguration@@ -85,24 +85,12 @@       -> GlobalFlags       -> FreezeFlags       -> IO ()-freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo+freeze verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo       globalFlags freezeFlags = do -    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos--    transport <- configureTransport verbosity-                 (flagToMaybe (globalHttpTransport globalFlags))--    pkgSpecifiers <- resolveUserTargets verbosity transport-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       [UserTargetLocalDir "."]--    sanityCheck pkgSpecifiers-    pkgs  <- planPackages-               verbosity comp platform mSandboxPkgInfo freezeFlags-               installedPkgIndex sourcePkgDb pkgSpecifiers+    pkgs  <- getFreezePkgs+               verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+               globalFlags freezeFlags      if null pkgs       then notice verbosity $ "No packages to be frozen. "@@ -112,11 +100,40 @@                      "The following packages would be frozen:"                    : formatPkgs pkgs -             else freezePackages verbosity pkgs+             else freezePackages verbosity globalFlags pkgs    where     dryRun = fromFlag (freezeDryRun freezeFlags) +-- | Get the list of packages whose versions would be frozen by the @freeze@+-- command.+getFreezePkgs :: Verbosity+              -> PackageDBStack+              -> RepoContext+              -> Compiler+              -> Platform+              -> ProgramConfiguration+              -> Maybe SandboxPackageInfo+              -> GlobalFlags+              -> FreezeFlags+              -> IO [PlanPackage]+getFreezePkgs verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+      globalFlags freezeFlags = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf++    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       [UserTargetLocalDir "."]++    sanityCheck pkgSpecifiers+    planPackages+               verbosity comp platform mSandboxPkgInfo freezeFlags+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers+  where     sanityCheck pkgSpecifiers = do       when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $         die $ "internal error: 'resolveUserTargets' returned "@@ -132,10 +149,11 @@              -> FreezeFlags              -> InstalledPackageIndex              -> SourcePackageDb-             -> [PackageSpecifier SourcePackage]+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]              -> IO [PlanPackage] planPackages verbosity comp platform mSandboxPkgInfo freezeFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers = do+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do    solver <- chooseSolver verbosity             (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)@@ -143,7 +161,7 @@    installPlan <- foldProgress logMsg die return $                    resolveDependencies-                     platform (compilerInfo comp)+                     platform (compilerInfo comp) pkgConfigDb                      solver                      resolverParams @@ -175,10 +193,8 @@      logMsg message rest = debug verbosity message >> rest -    stanzas = concat-        [ if testsEnabled      then [TestStanzas]  else []-        , if benchmarksEnabled then [BenchStanzas] else []-        ]+    stanzas = [ TestStanzas | testsEnabled ]+           ++ [ BenchStanzas | benchmarksEnabled ]     testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags     benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags @@ -199,24 +215,24 @@ --    freezing.  This is useful for removing previously installed packages --    which are no longer required from the install plan. pruneInstallPlan :: InstallPlan-                 -> [PackageSpecifier SourcePackage]+                 -> [PackageSpecifier UnresolvedSourcePackage]                  -> [PlanPackage] pruneInstallPlan installPlan pkgSpecifiers =-    either (const brokenPkgsErr)-           (removeSelf pkgIds . PackageIndex.allPackages) $-    InstallPlan.dependencyClosure installPlan pkgIds+    removeSelf pkgIds $+    InstallPlan.dependencyClosure installPlan (map fakeUnitId pkgIds)   where-    pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]-    removeSelf [thisPkg] = filter (\pp -> packageId pp /= thisPkg)+    pkgIds = [ packageId pkg+             | SpecificSourcePackage pkg <- pkgSpecifiers ]+    removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)     removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "                          ++ "unexpected package specifiers!"-    brokenPkgsErr = error "planPackages: installPlan contains broken packages"  -freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()-freezePackages verbosity pkgs = do+freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()+freezePackages verbosity globalFlags pkgs = do+     pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $-                   loadUserConfig verbosity ""+                   loadUserConfig verbosity ""  (flagToMaybe . globalConstraintsFile $ globalFlags)     writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv   where     addFrozenConstraints config =@@ -226,7 +242,7 @@             }         }     constraint pkg =-        (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig)+        (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile)       where         pkgIdToConstraint pkgId =             UserConstraintVersion (packageName pkgId)
+ cabal/cabal-install/Distribution/Client/GenBounds.hs view
@@ -0,0 +1,159 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GenBounds+-- Copyright   :  (c) Doug Beardsley 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal gen-bounds command for generating PVP-compliant version bounds.+-----------------------------------------------------------------------------+module Distribution.Client.GenBounds (+    genBounds+  ) where++import Data.Version+         ( Version(..), showVersion )+import Distribution.Client.Init+         ( incVersion )+import Distribution.Client.Freeze+         ( getFreezePkgs )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..), RepoContext )+import Distribution.Package+         ( Package(..), Dependency(..), PackageName(..)+         , packageName, packageVersion )+import Distribution.PackageDescription+         ( buildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack, compilerInfo )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Utils+         ( tryFindPackageDesc )+import Distribution.System+         ( Platform )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Version+         ( LowerBound(..), UpperBound(..), VersionRange(..), asVersionIntervals+         , orLaterVersion, earlierVersion, intersectVersionRanges )+import System.Directory+         ( getCurrentDirectory )++-- | Does this version range have an upper bound?+hasUpperBound :: VersionRange -> Bool+hasUpperBound vr =+    case asVersionIntervals vr of+      [] -> False+      is -> if snd (last is) == NoUpperBound then False else True++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.+--+-- This version is slightly different than the one in+-- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because+-- the user could be using a new function introduced in a.b.c which would make+-- ">= a.b" incorrect.+pvpize :: Version -> VersionRange+pvpize v = orLaterVersion (vn 3)+           `intersectVersionRanges`+           earlierVersion (incVersion 1 (vn 2))+  where+    vn n = (v { versionBranch = take n (versionBranch v) })++-- | Show the PVP-mandated version range for this package. The @padTo@ parameter+-- specifies the width of the package name column.+showBounds :: Package pkg => Int -> pkg -> String+showBounds padTo p = unwords $+    (padAfter padTo $ unPackageName $ packageName p) :+    map showInterval (asVersionIntervals $ pvpize $ packageVersion p)+  where+    padAfter :: Int -> String -> String+    padAfter n str = str ++ replicate (n - length str) ' '++    showInterval :: (LowerBound, UpperBound) -> String+    showInterval (LowerBound _ _, NoUpperBound) =+      error "Error: expected upper bound...this should never happen!"+    showInterval (LowerBound l _, UpperBound u _) =+      unwords [">=", showVersion l, "&& <", showVersion u]++-- | Entry point for the @gen-bounds@ command.+genBounds+    :: Verbosity+    -> PackageDBStack+    -> RepoContext+    -> Compiler+    -> Platform+    -> ProgramConfiguration+    -> Maybe SandboxPackageInfo+    -> GlobalFlags+    -> FreezeFlags+    -> IO ()+genBounds verbosity packageDBs repoCtxt comp platform conf mSandboxPkgInfo+      globalFlags freezeFlags = do++    let cinfo = compilerInfo comp++    cwd <- getCurrentDirectory+    path <- tryFindPackageDesc cwd+    gpd <- readPackageDescription verbosity path+    let epd = finalizePackageDescription [] (const True) platform cinfo [] gpd+    case epd of+      Left _ -> putStrLn "finalizePackageDescription failed"+      Right (pd,_) -> do+        let needBounds = filter (not . hasUpperBound . depVersion) $+                         buildDepends pd++        if (null needBounds)+          then putStrLn+               "Congratulations, all your dependencies have upper bounds!"+          else go needBounds+  where+     go needBounds = do+       pkgs  <- getFreezePkgs+                  verbosity packageDBs repoCtxt comp platform conf+                  mSandboxPkgInfo globalFlags freezeFlags++       putStrLn boundsNeededMsg++       let isNeeded pkg = unPackageName (packageName pkg)+                          `elem` map depName needBounds+       let thePkgs = filter isNeeded pkgs++       let padTo = maximum $ map (length . unPackageName . packageName) pkgs+       mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs++     depName :: Dependency -> String+     depName (Dependency (PackageName nm) _) = nm++     depVersion :: Dependency -> VersionRange+     depVersion (Dependency _ vr) = vr++-- | The message printed when some dependencies are found to be lacking proper+-- PVP-mandated bounds.+boundsNeededMsg :: String+boundsNeededMsg = unlines+  [ ""+  , "The following packages need bounds and here is a suggested starting point."+  , "You can copy and paste this into the build-depends section in your .cabal"+  , "file and it should work (with the appropriate removal of commas)."+  , ""+  , "Note that version bounds are a statement that you've successfully built and"+  , "tested your package and expect it to work with any of the specified package"+  , "versions (PROVIDED that those packages continue to conform with the PVP)."+  , "Therefore, the version bounds generated here are the most conservative"+  , "based on the versions that you are currently building with.  If you know"+  , "your package will work with versions outside the ranges generated here,"+  , "feel free to widen them."+  , ""+  ]
cabal/cabal-install/Distribution/Client/Get.hs view
@@ -21,7 +21,7 @@ import Distribution.Package          ( PackageId, packageId, packageName ) import Distribution.Simple.Setup-         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )+         ( Flag(..), fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils          ( notice, die, info, writeFileAtomic ) import Distribution.Verbosity@@ -30,13 +30,11 @@ import qualified Distribution.PackageDescription as PD  import Distribution.Client.Setup-         ( GlobalFlags(..), GetFlags(..) )+         ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency import Distribution.Client.FetchUtils-import Distribution.Client.HttpUtils-        ( configureTransport, HttpTransport(..) ) import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils         ( getSourcePackages )@@ -74,7 +72,7 @@  -- | Entry point for the 'cabal get' command. get :: Verbosity-    -> [Repo]+    -> RepoContext     -> GlobalFlags     -> GetFlags     -> [UserTarget]@@ -82,7 +80,7 @@ get verbosity _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -get verbosity repos globalFlags getFlags userTargets = do+get verbosity repoCtxt globalFlags getFlags userTargets = do   let useFork = case (getSourceRepository getFlags) of         NoFlag -> False         _      -> True@@ -90,11 +88,9 @@   unless useFork $     mapM_ checkTarget userTargets -  sourcePkgDb <- getSourcePackages verbosity repos--  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))+  sourcePkgDb <- getSourcePackages verbosity repoCtxt -  pkgSpecifiers <- resolveUserTargets verbosity transport+  pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                    (fromFlag $ globalWorldFile globalFlags)                    (packageIndex sourcePkgDb)                    userTargets@@ -108,7 +104,7 @@    if useFork     then fork pkgs-    else unpack transport pkgs+    else unpack pkgs    where     resolverParams sourcePkgDb pkgSpecifiers =@@ -117,16 +113,16 @@      prefix = fromFlagOrDefault "" (getDestDir getFlags) -    fork :: [SourcePackage] -> IO ()+    fork :: [UnresolvedSourcePackage] -> IO ()     fork pkgs = do       let kind = fromFlag . getSourceRepository $ getFlags       branchers <- findUsableBranchers       mapM_ (forkPackage verbosity branchers prefix kind) pkgs -    unpack :: HttpTransport -> [SourcePackage] -> IO ()-    unpack transport pkgs = do+    unpack :: [UnresolvedSourcePackage] -> IO ()+    unpack pkgs = do       forM_ pkgs $ \pkg -> do-        location <- fetchPackage transport verbosity (packageSource pkg)+        location <- fetchPackage verbosity repoCtxt (packageSource pkg)         let pkgid = packageId pkg             descOverride | usePristine = Nothing                          | otherwise   = packageDescrOverride pkg@@ -230,7 +226,7 @@                -- be created.             -> (Maybe PD.RepoKind)                -- ^ Which repo to choose.-            -> SourcePackage+            -> SourcePackage loc                -- ^ The package to fork.             -> IO () forkPackage verbosity branchers prefix kind src = do
+ cabal/cabal-install/Distribution/Client/Glob.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP, DeriveGeneric #-}++--TODO: [code cleanup] plausibly much of this module should be merged with+-- similar functionality in Cabal.+module Distribution.Client.Glob+    ( FilePathGlob(..)+    , FilePathRoot(..)+    , FilePathGlobRel(..)+    , Glob+    , GlobPiece(..)+    , matchFileGlob+    , matchFileGlobRel+    , matchGlob+    , isTrivialFilePathGlob+    , getFilePathRootDirectory+    ) where++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 (ReadP, (<++), (+++))+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp++import           System.FilePath+import           System.Directory+++-- | A file path specified by globbing+--+data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel+  deriving (Eq, Show, Generic)++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+type Glob = [GlobPiece]++-- | A piece of a globbing pattern+data GlobPiece = WildCard+               | Literal String+               | Union [Glob]+  deriving (Eq, Show, Generic)++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]+++-- | Match a globbing pattern against a file path component+--+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 :: [GlobPiece] -> String -> Bool++    goStart (WildCard:_) ('.':_)  = False+    goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)+                                        globs+    goStart rest               cs = go rest cs++    go []                 ""    = True+    go (Literal lit:rest) cs+      | Just cs' <- stripPrefix lit cs+                                = go rest cs'+      | 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 -> go (glob ++ rest) cs) globs+    go []                (_:_)  = False+    go (_:_)              ""    = False+++------------------------------------------------------------------------------+-- 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+      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 ','))++    literal = Literal `fmap` litchars1++    litchar = normal +++ escape++    normal  = Parse.satisfy (\c -> not (isGlobEscapedChar c)+                                && c /= '/' && c /= '\\')+    escape  = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar++    litchars1 :: ReadP r [Char]+    litchars1 = liftM2 (:) litchar litchars++    litchars :: ReadP r [Char]+    litchars = litchars1 <++ return []++isGlobEscapedChar :: Char -> Bool+isGlobEscapedChar '*'  = True+isGlobEscapedChar '{'  = True+isGlobEscapedChar '}'  = True+isGlobEscapedChar ','  = True+isGlobEscapedChar _    = False
+ cabal/cabal-install/Distribution/Client/GlobalFlags.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.GlobalFlags (+    GlobalFlags(..)+  , defaultGlobalFlags+  , RepoContext(..)+  , withRepoContext+  , withRepoContext'+  ) where++import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..) )+import Distribution.Compat.Semigroup+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, flagToMaybe )+import Distribution.Utils.NubList+         ( NubList, fromNubList )+import Distribution.Client.HttpUtils+         ( HttpTransport, configureTransport )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( info )++import Data.Maybe+         ( fromMaybe )+import Control.Concurrent+         ( MVar, newMVar, modifyMVar )+import Control.Exception+         ( throwIO )+import Control.Monad+         ( when )+import System.FilePath+         ( (</>) )+import Network.URI+         ( uriScheme, uriPath )+import Data.Map+         ( Map )+import qualified Data.Map as Map+import GHC.Generics ( Generic )++import qualified Hackage.Security.Client                    as Sec+import qualified Hackage.Security.Util.Path                 as Sec+import qualified Hackage.Security.Util.Pretty               as Sec+import qualified Hackage.Security.Client.Repository.Cache   as Sec+import qualified Hackage.Security.Client.Repository.Local   as Sec.Local+import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote+import qualified Distribution.Client.Security.HTTP          as Sec.HTTP++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+    globalVersion           :: Flag Bool,+    globalNumericVersion    :: Flag Bool,+    globalConfigFile        :: Flag FilePath,+    globalSandboxConfigFile :: Flag FilePath,+    globalConstraintsFile   :: Flag FilePath,+    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.+    globalCacheDir          :: Flag FilePath,+    globalLocalRepos        :: NubList FilePath,+    globalLogsDir           :: Flag FilePath,+    globalWorldFile         :: Flag FilePath,+    globalRequireSandbox    :: Flag Bool,+    globalIgnoreSandbox     :: Flag Bool,+    globalIgnoreExpiry      :: Flag Bool,    -- ^ Ignore security expiry dates+    globalHttpTransport     :: Flag String+  } deriving Generic++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion           = Flag False,+    globalNumericVersion    = Flag False,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalConstraintsFile   = mempty,+    globalRemoteRepos       = mempty,+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty,+    globalRequireSandbox    = Flag False,+    globalIgnoreSandbox     = Flag False,+    globalIgnoreExpiry      = Flag False,+    globalHttpTransport     = mempty+  }++instance Monoid GlobalFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup GlobalFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Repo context+-- ------------------------------------------------------------++-- | Access to repositories+data RepoContext = RepoContext {+    -- | All user-specified repositories+    repoContextRepos :: [Repo]++    -- | Get the HTTP transport+    --+    -- The transport will be initialized on the first call to this function.+    --+    -- NOTE: It is important that we don't eagerly initialize the transport.+    -- Initializing the transport is not free, and especially in contexts where+    -- we don't know a-priori whether or not we need the transport (for instance+    -- when using cabal in "nix mode") incurring the overhead of transport+    -- initialization on _every_ invocation (eg @cabal build@) is undesirable.+  , repoContextGetTransport :: IO HttpTransport++    -- | Get the (initialized) secure repo+    --+    -- (the 'Repo' type itself is stateless and must remain so, because it+    -- must be serializable)+  , repoContextWithSecureRepo :: forall a.+                                 Repo+                              -> (forall down. Sec.Repository down -> IO a)+                              -> IO a++    -- | Should we ignore expiry times (when checking security)?+  , repoContextIgnoreExpiry :: Bool+  }++-- | Wrapper around 'Repository', hiding the type argument+data SecureRepo = forall down. SecureRepo (Sec.Repository down)++withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a+withRepoContext verbosity globalFlags =+    withRepoContext'+      verbosity+      (fromNubList (globalRemoteRepos   globalFlags))+      (fromNubList (globalLocalRepos    globalFlags))+      (fromFlag    (globalCacheDir      globalFlags))+      (flagToMaybe (globalHttpTransport globalFlags))+      (flagToMaybe (globalIgnoreExpiry  globalFlags))++withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath]+                 -> FilePath  -> Maybe String -> Maybe Bool+                 -> (RepoContext -> IO a)+                 -> IO a+withRepoContext' verbosity remoteRepos localRepos+                 sharedCacheDir httpTransport ignoreExpiry = \callback -> do+    transportRef <- newMVar Nothing+    let httpLib = Sec.HTTP.transportAdapter+                    verbosity+                    (getTransport transportRef)+    initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->+      callback RepoContext {+          repoContextRepos          = allRemoteRepos+                                   ++ map RepoLocal localRepos+        , repoContextGetTransport   = getTransport transportRef+        , repoContextWithSecureRepo = withSecureRepo secureRepos'+        , repoContextIgnoreExpiry   = fromMaybe False ignoreExpiry+        }+  where+    secureRemoteRepos =+      [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]+    allRemoteRepos =+      [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir+      | remote <- remoteRepos+      , let cacheDir = sharedCacheDir </> remoteRepoName remote+            isSecure = remoteRepoSecure remote == Just True+      ]++    getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport+    getTransport transportRef =+      modifyMVar transportRef $ \mTransport -> do+        transport <- case mTransport of+          Just tr -> return tr+          Nothing -> configureTransport verbosity httpTransport+        return (Just transport, transport)++    withSecureRepo :: Map Repo SecureRepo+                   -> Repo+                   -> (forall down. Sec.Repository down -> IO a)+                   -> IO a+    withSecureRepo secureRepos repo callback =+      case Map.lookup repo secureRepos of+        Just (SecureRepo secureRepo) -> callback secureRepo+        Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"++-- | Initialize the provided secure repositories+--+-- Assumed invariant: `remoteRepoSecure` should be set for all these repos.+initSecureRepos :: forall a. Verbosity+                -> Sec.HTTP.HttpLib+                -> [(RemoteRepo, FilePath)]+                -> (Map Repo SecureRepo -> IO a)+                -> IO a+initSecureRepos verbosity httpLib repos callback = go Map.empty repos+  where+    go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a+    go !acc [] = callback acc+    go !acc ((r,cacheDir):rs) = do+      cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir+      initSecureRepo verbosity httpLib r cachePath $ \r' ->+        go (Map.insert (RepoSecure r cacheDir) r' acc) rs++-- | Initialize the given secure repo+--+-- The security library has its own concept of a "local" repository, distinct+-- from @cabal-install@'s; these are secure repositories, but live in the local+-- file system. We use the convention that these repositories are identified by+-- URLs of the form @file:/path/to/local/repo@.+initSecureRepo :: Verbosity+               -> Sec.HTTP.HttpLib+               -> RemoteRepo  -- ^ Secure repo ('remoteRepoSecure' assumed)+               -> Sec.Path Sec.Absolute -- ^ Cache dir+               -> (SecureRepo -> IO a)  -- ^ Callback+               -> IO a+initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do+    withRepo $ \r -> do+      requiresBootstrap <- Sec.requiresBootstrap r+      when requiresBootstrap $ Sec.uncheckClientErrors $+        Sec.bootstrap r+          (map Sec.KeyId    remoteRepoRootKeys)+          (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))+      callback $ SecureRepo r+  where+    -- Initialize local or remote repo depending on the URI+    withRepo :: (forall down. Sec.Repository down -> IO a) -> IO a+    withRepo callback | uriScheme remoteRepoURI == "file:" = do+      dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)+      Sec.Local.withRepository dir+                               cache+                               Sec.hackageRepoLayout+                               Sec.hackageIndexLayout+                               logTUF+                               callback+    withRepo callback =+      Sec.Remote.withRepository httpLib+                                [remoteRepoURI]+                                Sec.Remote.defaultRepoOpts+                                cache+                                Sec.hackageRepoLayout+                                Sec.hackageIndexLayout+                                logTUF+                                callback++    cache :: Sec.Cache+    cache = Sec.Cache {+        cacheRoot   = cachePath+      , cacheLayout = Sec.cabalCacheLayout+      }++    -- We display any TUF progress only in verbose mode, including any transient+    -- verification errors. If verification fails, then the final exception that+    -- is thrown will of course be shown.+    logTUF :: Sec.LogMessage -> IO ()+    logTUF = info verbosity . Sec.pretty
cabal/cabal-install/Distribution/Client/Haddock.hs view
@@ -17,6 +17,7 @@     where  import Data.List (maximumBy)+import Data.Foldable (forM_) import System.Directory (createDirectoryIfMissing, renameFile) import System.FilePath ((</>), splitFileName) import Distribution.Package@@ -40,9 +41,7 @@ regenerateHaddockIndex verbosity pkgs conf index = do       (paths, warns) <- haddockPackagePaths pkgs' Nothing       let paths' = [ (interface, html) | (interface, Just html) <- paths]-      case warns of-        Nothing -> return ()-        Just m  -> debug verbosity m+      forM_ warns (debug verbosity)        (confHaddock, _, _) <-           requireProgramVersion verbosity haddockProgram
cabal/cabal-install/Distribution/Client/HttpUtils.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE CPP, BangPatterns #-} -------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists+-- | Separate module for HTTP actions, using a proxy server if one exists. ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils (     DownloadResult(..),     configureTransport,     HttpTransport(..),+    HttpCode,     downloadURI,     transportCheckHttps,     remoteRepoCheckHttps,@@ -18,7 +19,7 @@          , Header(..), HeaderName(..), lookupHeader ) import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI-         ( URI (..), URIAuth (..) )+         ( URI (..), URIAuth (..), uriToString ) import Network.Browser          ( browse, setOutHandler, setErrHandler, setProxy          , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )@@ -32,7 +33,7 @@ import Data.List          ( isPrefixOf, find, intercalate ) import Data.Maybe-         ( listToMaybe, maybeToList )+         ( listToMaybe, maybeToList, fromMaybe ) import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils@@ -69,7 +70,7 @@         ( IOEncoding(..), getEffectiveEnvironment ) import Numeric (showHex) import System.Directory (canonicalizePath)-import System.IO (hClose, hPutStr)+import System.IO (hClose) import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..))@@ -115,7 +116,7 @@           = transport      withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do-      result <- getHttp transport' verbosity uri etag tmpFile+      result <- getHttp transport' verbosity uri etag tmpFile []        -- Only write the etag if we get a 200 response code.       -- A 304 still sends us an etag header.@@ -196,7 +197,8 @@ isOldHackageURI uri     = case uriAuthority uri of         Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->-            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+            FilePath.Posix.splitDirectories (uriPath uri)+            == ["/","packages","archive"]         _ -> False  @@ -208,7 +210,7 @@       -- | GET a URI, with an optional ETag (to do a conditional fetch),       -- write the resource to the given file and return the HTTP status code,       -- and optional ETag.-      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath+      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]                -> IO (HttpCode, Maybe ETag),        -- | POST a resource to a URI, with optional auth (username, password)@@ -222,11 +224,17 @@       postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth                    -> IO (HttpCode, String), +      -- | PUT a file resource to a URI, with optional auth+      -- (username, password), extra headers and return the HTTP status code+      -- and any error string.+      putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]+                  -> IO (HttpCode, String),+       -- | Whether this transport supports https or just http.       transportSupportsHttps :: Bool,        -- | Whether this transport implementation was specifically chosen by-      -- the user via configuration, or whether it was automatically selected. +      -- the user via configuration, or whether it was automatically selected.       -- Strictly speaking this is not a property of the transport itself but       -- about how it was chosen. Nevertheless it's convenient to keep here.       transportManuallySelected :: Bool@@ -310,9 +318,9 @@  curlTransport :: ConfiguredProgram -> HttpTransport curlTransport prog =-    HttpTransport gethttp posthttp posthttpfile True False+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False   where-    gethttp verbosity uri etag destPath = do+    gethttp verbosity uri etag destPath reqHeaders = do         withTempFile (takeDirectory destPath)                      "curl-headers.txt" $ \tmpFile tmpHandle -> do           hClose tmpHandle@@ -326,6 +334,9 @@                 ++ concat                    [ ["--header", "If-None-Match: " ++ t]                    | t <- maybeToList etag ]+                ++ concat+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- reqHeaders ]            resp <- getProgramInvocationOutput verbosity                     (programInvocation prog args)@@ -335,17 +346,41 @@      posthttp = noPostYet +    addAuthConfig auth progInvocation = progInvocation+      { progInvokeInput = do+          (uname, passwd) <- auth+          return $ unlines+            [ "--digest"+            , "--user " ++ uname ++ ":" ++ passwd+            ]+      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation+      }+     posthttpfile verbosity uri path auth = do         let args = [ show uri                    , "--form", "package=@"++path-                   , "--write-out", "%{http_code}"+                   , "--write-out", "\n%{http_code}"                    , "--user-agent", userAgent                    , "--silent", "--show-error"-                   , "--header", "Accept: text/plain" ]+                   , "--header", "Accept: text/plain"+                   ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse uri resp ""+        return (code, err)++    puthttpfile verbosity uri path auth headers = do+        let args = [ show uri+                   , "--request", "PUT", "--data-binary", "@"++path+                   , "--write-out", "\n%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--header", "Accept: text/plain"+                   ]                 ++ concat-                   [ ["--digest", "--user", uname ++ ":" ++ passwd]-                   | (uname,passwd) <- maybeToList auth ]-        resp <- getProgramInvocationOutput verbosity+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- headers ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth                   (programInvocation prog args)         (code, err, _etag) <- parseResponse uri resp ""         return (code, err)@@ -357,11 +392,13 @@             case reverse (lines resp) of               (codeLine:rerrLines) ->                 case readMaybe (trim codeLine) of-                  Just i  -> let errstr = unlines (reverse rerrLines)+                  Just i  -> let errstr = mkErrstr rerrLines                               in Just (i, errstr)                   Nothing -> Nothing               []          -> Nothing +          mkErrstr = unlines . reverse . dropWhile (all isSpace)+           mb_etag :: Maybe ETag           mb_etag  = listToMaybe $ reverse                      [ etag@@ -374,15 +411,14 @@  wgetTransport :: ConfiguredProgram -> HttpTransport wgetTransport prog =-    HttpTransport gethttp posthttp posthttpfile True False+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False   where-    gethttp verbosity uri etag destPath = do-        resp <- runWGet verbosity args+    gethttp verbosity uri etag destPath reqHeaders = do+        resp <- runWGet verbosity uri args         (code, _err, etag') <- parseResponse uri resp         return (code, etag')       where-        args = [ show uri-               , "--output-document=" ++ destPath+        args = [ "--output-document=" ++ destPath                , "--user-agent=" ++ userAgent                , "--tries=5"                , "--timeout=15"@@ -390,6 +426,8 @@             ++ concat                [ ["--header", "If-None-Match: " ++ t]                | t <- maybeToList etag ]+            ++ [ "--header=" ++ show name ++ ": " ++ value+               | Header name value <- reqHeaders ]      posthttp = noPostYet @@ -400,25 +438,45 @@           BS.hPut tmpHandle body           BS.writeFile "wget.in" body           hClose tmpHandle-          let args = [ show uri-                     , "--post-file=" ++ tmpFile+          let args = [ "--post-file=" ++ tmpFile                      , "--user-agent=" ++ userAgent                      , "--server-response"-                     , "--header=Content-type: multipart/form-data; " ++ +                     , "--header=Content-type: multipart/form-data; " ++                                               "boundary=" ++ boundary ]-                  ++ concat-                     [ [ "--http-user=" ++ uname-                       , "--http-password=" ++ passwd ]-                     | (uname,passwd) <- maybeToList auth ]--          resp <- runWGet verbosity args+          resp <- runWGet verbosity (addUriAuth auth uri) args           (code, err, _etag) <- parseResponse uri resp           return (code, err) -    runWGet verbosity args = do+    puthttpfile verbosity uri path auth headers = do+        let args = [ "--method=PUT", "--body-file="++path+                   , "--user-agent=" ++ userAgent+                   , "--server-response"+                   , "--header=Accept: text/plain" ]+                ++ [ "--header=" ++ show name ++ ": " ++ value+                   | Header name value <- headers ]++        resp <- runWGet verbosity (addUriAuth auth uri) args+        (code, err, _etag) <- parseResponse uri resp+        return (code, err)++    addUriAuth Nothing uri = uri+    addUriAuth (Just (user, pass)) uri = uri+      { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }+      }+     where+      a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)++    runWGet verbosity uri args = do+        -- We pass the URI via STDIN because it contains the users' credentials+        -- and sensitive data should not be passed via command line arguments.+        let+          invocation = (programInvocation prog ("--input-file=-" : args))+            { progInvokeInput = Just (uriToString id uri "")+            }+         -- wget returns its output on stderr rather than stdout         (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity-                                 (programInvocation prog args)+                                 invocation         -- wget returns exit code 8 for server "errors" like "304 not modified"         if exitCode == ExitSuccess || exitCode == ExitFailure 8           then return resp@@ -450,95 +508,128 @@  powershellTransport :: ConfiguredProgram -> HttpTransport powershellTransport prog =-    HttpTransport gethttp posthttp posthttpfile True False+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False   where-    gethttp verbosity uri etag destPath =-        withTempFile (takeDirectory destPath)-                     "psScript.ps1" $ \tmpFile tmpHandle -> do-           hPutStr tmpHandle script-           hClose tmpHandle-           let args = ["-InputFormat", "None", "-File", tmpFile]-           resp <- getProgramInvocationOutput verbosity-                     (programInvocation prog args)-           parseResponse resp+    gethttp verbosity uri etag destPath reqHeaders = do+      resp <- runPowershellScript verbosity $+        webclientScript+          (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))+          [ "$wc.DownloadFile(" ++ escape (show uri)+              ++ "," ++ escape destPath ++ ");"+          , "Write-Host \"200\";"+          , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");"+          ]+      parseResponse resp       where-        script =-          concatMap (++";\n") $-            [ "$wc = new-object system.net.webclient"-            , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")"]-         ++ [ "$wc.Headers.Add(\"If-None-Match\"," ++ t ++ ")"-            | t <- maybeToList etag ]-         ++ [ "Try {"-            ,  "$wc.DownloadFile("++ escape (show uri) ++-                              "," ++ escape destPath ++ ")"-            , "} Catch {Write-Error $_; Exit(5);}"-            , "Write-Host \"200\""-            , "Write-Host $wc.ResponseHeaders.Item(\"ETag\")"-            , "Exit" ]--        escape x = '"' : x ++ "\"" --TODO write/find real escape.-         parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of           Just i  -> return (i, Nothing) -- TODO extract real etag           Nothing -> statusParseFail uri x+        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]      posthttp = noPostYet      posthttpfile verbosity uri path auth =-        withTempFile (takeDirectory path)-                     (takeFileName path) $ \tmpFile tmpHandle ->-        withTempFile (takeDirectory path)-                     "psScript.ps1" $ \tmpScriptFile tmpScriptHandle -> do-          (body, boundary) <- generateMultipartBody path-          BS.hPut tmpHandle body-          hClose tmpHandle+      withTempFile (takeDirectory path)+                   (takeFileName path) $ \tmpFile tmpHandle -> do+        (body, boundary) <- generateMultipartBody path+        BS.hPut tmpHandle body+        hClose tmpHandle+        fullPath <- canonicalizePath tmpFile -          fullPath <- canonicalizePath tmpFile-          hPutStr tmpScriptHandle (script fullPath boundary)-          hClose tmpScriptHandle-          let args = ["-InputFormat", "None", "-File", tmpScriptFile]-          resp <- getProgramInvocationOutput verbosity-                    (programInvocation prog args)-          parseResponse resp-      where-        script fullPath boundary = -          concatMap (++";\n") $-            [ "$wc = new-object system.net.webclient"-            , "$wc.Headers.Add(\"user-agent\","++escape userAgent++")"-            , "$wc.Headers.Add(\"Content-type\"," ++-                              "\"multipart/form-data; " ++-                              "boundary="++boundary++"\")" ]-         ++ [ "$wc.Credentials = new-object System.Net.NetworkCredential("-              ++ escape uname ++ "," ++ escape passwd ++ ",\"\")"-            | (uname,passwd) <- maybeToList auth ]-         ++ [ "Try {"-            , "$bytes = [System.IO.File]::ReadAllBytes("++escape fullPath++")"-            , "$wc.UploadData("++ escape (show uri) ++ ",$bytes)"-            , "} Catch {Write-Error $_; Exit(1);}"-            , "Write-Host \"200\""-            , "Exit" ]+        let contentHeader = Header HdrContentType+              ("multipart/form-data; boundary=" ++ boundary)+        resp <- runPowershellScript verbosity $ webclientScript+          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)+          (uploadFileAction "POST" uri fullPath)+        parseUploadResponse uri resp -        escape x = show x+    puthttpfile verbosity uri path auth headers = do+      fullPath <- canonicalizePath path+      resp <- runPowershellScript verbosity $ webclientScript+        (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)+        (uploadFileAction "PUT" uri fullPath)+      parseUploadResponse uri resp -        parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of-          Just i -> return (i, x) -- TODO extract real etag-          Nothing -> statusParseFail uri x+    runPowershellScript verbosity script = do+      let args =+            [ "-InputFormat", "None"+            -- the default execution policy doesn't allow running+            -- unsigned scripts, so we need to tell powershell to bypass it+            , "-ExecutionPolicy", "bypass"+            , "-NoProfile", "-NonInteractive"+            , "-Command", "-"+            ]+      getProgramInvocationOutput verbosity (programInvocation prog args)+        { progInvokeInput = Just (script ++ "\nExit(0);")+        } +    escape = show +    useragentHeader = Header HdrUserAgent userAgent+    extraHeaders = [Header HdrAccept "text/plain", useragentHeader]++    setupHeaders headers =+      [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"+      | Header name value <- headers+      ]++    setupAuth auth =+      [ "$wc.Credentials = new-object System.Net.NetworkCredential("+          ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"+      | (uname,passwd) <- maybeToList auth+      ]++    uploadFileAction method uri fullPath =+      [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");"+      , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ ","+        ++ show method ++ ", $fileBytes);"+      , "Write-Host \"200\";"+      , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));"+      ]++    parseUploadResponse uri resp = case lines (trim resp) of+      (codeStr : message)+        | Just code <- readMaybe codeStr -> return (code, unlines message)+      _ -> statusParseFail uri resp++    webclientScript setup action = unlines+      [ "$wc = new-object system.net.webclient;"+      , unlines setup+      , "Try {"+      , unlines (map ("  " ++) action)+      , "} Catch [System.Net.WebException] {"+      , "  $exception = $_.Exception;"+      , "  If ($exception.Status -eq "+        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"+      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"+      , "    $reader = new-object "+        ++ "System.IO.StreamReader($response.GetResponseStream());"+      , "    Write-Host ($response.StatusCode -as [int]);"+      , "    Write-Host $reader.ReadToEnd();"+      , "  } Else {"+      , "    Write-Host $exception.Message;"+      , "  }"+      , "} Catch {"+      , "  Write-Host $_.Exception.Message;"+      , "}"+      ]++ ------------------------------------------------------------------------------ -- The builtin plain HttpTransport --  plainHttpTransport :: HttpTransport plainHttpTransport =-    HttpTransport gethttp posthttp posthttpfile False False+    HttpTransport gethttp posthttp posthttpfile puthttpfile False False   where-    gethttp verbosity uri etag destPath = do+    gethttp verbosity uri etag destPath reqHeaders = do       let req = Request{                   rqURI     = uri,                   rqMethod  = GET,                   rqHeaders = [ Header HdrIfNoneMatch t-                              | t <- maybeToList etag ],+                              | t <- maybeToList etag ]+                           ++ reqHeaders,                   rqBody    = BS.empty                 }       (_, resp) <- cabalBrowse verbosity Nothing (request req)@@ -561,6 +652,19 @@                   rqURI     = uri,                   rqMethod  = POST,                   rqHeaders = headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    puthttpfile verbosity uri path auth headers = do+      body <- BS.readFile path+      let req = Request {+                  rqURI     = uri,+                  rqMethod  = PUT,+                  rqHeaders = Header HdrContentLength (show (BS.length body))+                            : Header HdrAccept "text/plain"+                            : headers,                   rqBody    = body                 }       (_, resp) <- cabalBrowse verbosity auth (request req)
cabal/cabal-install/Distribution/Client/IndexUtils.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.IndexUtils@@ -14,17 +17,23 @@ module Distribution.Client.IndexUtils (   getIndexFileAge,   getInstalledPackages,+  Configure.getInstalledPackagesMonitorFiles,   getSourcePackages,-  getSourcePackagesStrict,+  getSourcePackagesMonitorFiles, +  Index(..),+  PackageEntry(..),   parsePackageIndex,-  readRepoIndex,   updateRepoIndexCache,   updatePackageIndexCacheFile,+  readCacheStrict,    BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where +import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types @@ -45,7 +54,7 @@ import Distribution.Simple.Program          ( ProgramConfiguration ) import qualified Distribution.Simple.Configure as Configure-         ( getInstalledPackages )+         ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.ParseUtils          ( ParseResult(..) ) import Distribution.Version@@ -56,9 +65,11 @@          ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils          ( die, warn, info, fromUTF8, ignoreBOM )+import Distribution.Client.Setup+         ( RepoContext(..) )  import Data.Char   (isAlphaNum)-import Data.Maybe  (mapMaybe)+import Data.Maybe  (mapMaybe, catMaybes, maybeToList) import Data.List   (isPrefixOf) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..))@@ -75,22 +86,25 @@                                  , tryFindAddSourcePackageDesc ) import Distribution.Compat.Exception (catchIO) import Distribution.Client.Compat.Time (getFileAge, getModTime)-import System.Directory (doesFileExist)-import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.Directory (doesFileExist, doesDirectoryExist)+import System.FilePath+         ( (</>), takeExtension, replaceExtension, splitDirectories, normalise ) import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) +import qualified Hackage.Security.Client    as Sec+import qualified Hackage.Security.Util.Some as Sec +-- | Reduced-verbosity version of 'Configure.getInstalledPackages' getInstalledPackages :: Verbosity -> Compiler                      -> PackageDBStack -> ProgramConfiguration                      -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs conf =     Configure.getInstalledPackages verbosity' comp packageDbs conf   where-    --FIXME: make getInstalledPackages use sensible verbosity in the first place     verbosity'  = lessVerbose verbosity  ------------------------------------------------------------------------@@ -104,31 +118,17 @@ -- 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install.----getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackages verbosity repos = getSourcePackages' verbosity repos-                                    ReadPackageIndexLazyIO---- | Like 'getSourcePackages', but reads the package index strictly. Useful if--- you want to write to the package index after having read it.-getSourcePackagesStrict :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackagesStrict verbosity repos = getSourcePackages' verbosity repos-                                          ReadPackageIndexStrict---- | Common implementation used by getSourcePackages and--- getSourcePackagesStrict.-getSourcePackages' :: Verbosity -> [Repo] -> ReadPackageIndexMode-                      -> IO SourcePackageDb-getSourcePackages' verbosity [] _mode = do+getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb+getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."   return SourcePackageDb {     packageIndex       = mempty,     packagePreferences = mempty   }-getSourcePackages' verbosity repos mode = do+getSourcePackages verbosity repoCtxt = do   info verbosity "Reading available packages..."-  pkgss <- mapM (\r -> readRepoIndex verbosity r mode) repos+  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -139,6 +139,13 @@     packagePreferences = prefs'   } +readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])+readCacheStrict verbosity index mkPkg = do+    updateRepoIndexCache verbosity index+    cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)+    withFile (indexFile index) ReadMode $ \indexHnd ->+      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict+ -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. --@@ -146,16 +153,13 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode-              -> IO (PackageIndex SourcePackage, [Dependency])-readRepoIndex verbosity repo mode =-  let indexFile = repoLocalDir repo </> "00-index.tar"-      cacheFile = repoLocalDir repo </> "00-index.cache"-  in handleNotFound $ do+readRepoIndex :: Verbosity -> RepoContext -> Repo+              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency])+readRepoIndex verbosity repoCtxt repo =+  handleNotFound $ do     warnIfIndexIsOld =<< getIndexFileAge repo-    whenCacheOutOfDate indexFile cacheFile $ do-      updatePackageIndexCacheFile verbosity indexFile cacheFile-    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode+    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)    where     mkAvailablePackage pkgEntry =@@ -174,51 +178,59 @@      handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e       then do-        case repoKind repo of-          Left  remoteRepo -> warn verbosity $-               "The package list for '" ++ remoteRepoName remoteRepo-            ++ "' does not exist. Run 'hackport update' to download it."-          Right _localRepo -> warn verbosity $-               "The package list for the local repo '" ++ repoLocalDir repo+        case repo of+          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoLocal{..}  -> warn verbosity $+               "The package list for the local repo '" ++ repoLocalDir             ++ "' is missing. The repo is invalid."         return mempty       else ioError e      isOldThreshold = 15 --days     warnIfIndexIsOld dt = do-      when (dt >= isOldThreshold) $ case repoKind repo of-        Left  remoteRepo -> warn verbosity $-             "The package list for '" ++ remoteRepoName remoteRepo-          ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "-          ++ "'hackport update' to get the latest list of available packages."-        Right _localRepo -> return ()+      when (dt >= isOldThreshold) $ case repo of+        RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoLocal{..}  -> return () +    errMissingPackageList repoRemote =+         "The package list for '" ++ remoteRepoName repoRemote+      ++ "' does not exist. Run 'hackport update' to download it."+    errOutdatedPackageList repoRemote dt =+         "The package list for '" ++ remoteRepoName repoRemote+      ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "+      ++ "'cabal update' to get the latest list of available packages."  -- | Return the age of the index file in days (as a Double). getIndexFileAge :: Repo -> IO Double getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar" +-- | A set of files (or directories) that can be monitored to detect when+-- there might have been a change in the source packages.+--+getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]+getSourcePackagesMonitorFiles repos =+    [ repoLocalDir repo </> "00-index.cache"+    | repo <- repos ]  -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. ---updateRepoIndexCache :: Verbosity -> Repo -> IO ()-updateRepoIndexCache verbosity repo =-    whenCacheOutOfDate indexFile cacheFile $ do-      updatePackageIndexCacheFile verbosity indexFile cacheFile-  where-    indexFile = repoLocalDir repo </> "00-index.tar"-    cacheFile = repoLocalDir repo </> "00-index.cache"+updateRepoIndexCache :: Verbosity -> Index -> IO ()+updateRepoIndexCache verbosity index =+    whenCacheOutOfDate index $ do+      updatePackageIndexCacheFile verbosity index -whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO ()-whenCacheOutOfDate origFile cacheFile action = do-  exists <- doesFileExist cacheFile+whenCacheOutOfDate :: Index -> IO () -> IO ()+whenCacheOutOfDate index action = do+  exists <- doesFileExist $ cacheFile index   if not exists     then action     else do-      origTime  <- getModTime origFile-      cacheTime <- getModTime cacheFile-      when (origTime > cacheTime) action+      indexTime <- getModTime $ indexFile index+      cacheTime <- getModTime $ cacheFile index+      when (indexTime > cacheTime) action  ------------------------------------------------------------------------ -- Reading the index file@@ -245,8 +257,6 @@ typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode -type MkPackageEntry = IO PackageEntry- instance Package PackageEntry where   packageId (NormalPackage  pkgid _ _ _) = pkgid   packageId (BuildTreeRef _ pkgid _ _ _) = pkgid@@ -261,38 +271,47 @@  data PackageOrDep = Pkg PackageEntry | Dep Dependency -parsePackageIndex :: ByteString-                  -> [IO PackageOrDep]-parsePackageIndex = accum 0 . Tar.read+-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files+--+-- We read the index using 'Tar.read', which gives us a lazily constructed+-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',+-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a+-- function over this to translate it to a list of IO actions returning+-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of+-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.+parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)]+parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read   where-    accum blockNo es = case es of-      Tar.Fail err   -> error ("parsePackageIndex: " ++ err)-      Tar.Done       -> []-      Tar.Next e es' -> ps ++ accum blockNo' es'-        where-          ps       = extract blockNo e-          blockNo' = blockNo + Tar.entrySizeInBlocks e-+    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]     extract blockNo entry = tryExtractPkg ++ tryExtractPrefs       where-        maybeToList Nothing  = []-        maybeToList (Just a) = [a]-         tryExtractPkg = do           mkPkgEntry <- maybeToList $ extractPkg entry blockNo-          return (fmap Pkg mkPkgEntry)+          return $ fmap (fmap Pkg) mkPkgEntry          tryExtractPrefs = do-          (_,prefs') <- maybeToList $ extractPrefs entry-          map (return . Dep) $ prefs'+          prefs' <- maybeToList $ extractPrefs entry+          fmap (return . Just . Dep) prefs' -extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry+-- | Turn the 'Entries' data structure from the @tar@ package into a list,+-- and pair each entry with its block number.+--+-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read+-- as far as the list is evaluated.+tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]+tarEntriesList = go 0+  where+    go !_ Tar.Done         = []+    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)+    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'++extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) extractPkg entry blockNo = case Tar.entryContent entry of   Tar.NormalFile content _      | takeExtension fileName == ".cabal"     -> case splitDirectories (normalise fileName) of         [pkgname,vers,_] -> case simpleParse vers of-          Just ver -> Just $ return (NormalPackage pkgid descr content blockNo)+          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (PackageName pkgname) ver               parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack@@ -307,19 +326,22 @@   Tar.OtherEntryType typeCode content _     | Tar.isBuildTreeRefTypeCode typeCode ->       Just $ do-        let path   = byteStringToFilePath content-            err = "Error reading package index."-        cabalFile <- tryFindAddSourcePackageDesc path err-        descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile-        return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)-                              descr path blockNo+        let path = byteStringToFilePath content+        dirExists <- doesDirectoryExist path+        result <- if not dirExists then return Nothing+                  else do+                    cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index."+                    descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile+                    return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)+                                                 descr path blockNo+        return result    _ -> Nothing    where     fileName = Tar.entryPath entry -extractPrefs :: Tar.Entry -> Maybe (FilePath, [Dependency])+extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of {-  -- get rid of hackage's preferred-versions@@ -327,40 +349,105 @@  -- broken packages with improper depends   Tar.NormalFile content _      | takeFileName entrypath == "preferred-versions"-    -> Just (entrypath, prefs)+    -> Just prefs     where       entrypath = Tar.entryPath entry-      prefs     = parsePreferredVersions (BS.Char8.unpack content)+      prefs     = parsePreferredVersions content -}   _ -> Nothing -parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions :: ByteString -> [Dependency] parsePreferredVersions = mapMaybe simpleParse                        . filter (not . isPrefixOf "--")                        . lines+                       . BS.Char8.unpack -- TODO: Are we sure no unicode?  ------------------------------------------------------------------------ -- Reading and updating the index cache -- +-- | Variation on 'sequence' which evaluates the actions lazily+--+-- Pattern matching on the result list will execute just the first action;+-- more generally pattern matching on the first @n@ '(:)' nodes will execute+-- the first @n@ actions. lazySequence :: [IO a] -> IO [a]-lazySequence [] = return []-lazySequence (x:xs) = unsafeInterleaveIO $ do-    x'  <- unsafeInterleaveIO x-    xs' <- lazySequence xs-    return (x':xs')+lazySequence = unsafeInterleaveIO . go+  where+    go []     = return []+    go (x:xs) = do x'  <- x+                   xs' <- lazySequence xs+                   return (x' : xs') -updatePackageIndexCacheFile :: Verbosity -> FilePath -> FilePath -> IO ()-updatePackageIndexCacheFile verbosity indexFile cacheFile = do-    info verbosity ("Updating index cache file " ++ cacheFile)-    pkgsOrPrefs <- return-                 . parsePackageIndex-                 . maybeDecompress-               =<< BS.readFile indexFile-    entries <- lazySequence pkgsOrPrefs-    let cache = map toCache entries-    writeFile cacheFile (showIndexCache cache)+-- | Which index do we mean?+data Index =+    -- | The main index for the specified repository+    RepoIndex RepoContext Repo++    -- | A sandbox-local repository+    -- Argument is the location of the index file+  | SandboxIndex FilePath++indexFile :: Index -> FilePath+indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"+indexFile (SandboxIndex index)   = index++cacheFile :: Index -> FilePath+cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"+cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"++updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()+updatePackageIndexCacheFile verbosity index = do+    info verbosity ("Updating index cache file " ++ cacheFile index)+    withIndexEntries index $ \entries -> do+      let cache = Cache { cacheEntries = entries }+      writeFile (cacheFile index) (showIndexCache cache)++-- | Read the index (for the purpose of building a cache)+--+-- The callback is provided with list of cache entries, which is guaranteed to+-- be lazily constructed. This list must ONLY be used in the scope of the+-- callback; when the callback is terminated the file handle to the index will+-- be closed and further attempts to read from the list will result in (pure)+-- I/O exceptions.+--+-- In the construction of the index for a secure repo we take advantage of the+-- index built by the @hackage-security@ library to avoid reading the @.tar@+-- file as much as possible (we need to read it only to extract preferred+-- versions). This helps performance, but is also required for correctness:+-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions+-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);+-- by reading the already-built cache from the security library we will be sure+-- to only read the latest versions of all files.+--+-- TODO: It would be nicer if we actually incrementally updated @cabal@'s+-- cache, rather than reconstruct it from zero on each update. However, this+-- would require a change in the cache format.+withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a+withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =+    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->+      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do+        let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile))+               -> IO [IndexCacheEntry]+            mk (_, _fp, Nothing) =+              return [] -- skip unrecognized file+            mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) =+              return [] -- skip metadata+            mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do+              let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry)+              return [CachePackageId pkgId blockNo]+            mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do+              content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file+              return $ map CachePreference (parsePreferredVersions content)+        entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory)+        callback $ concat entriess+withIndexEntries index callback = do+    withFile (indexFile index) ReadMode $ \h -> do+      bs          <- maybeDecompress `fmap` BS.hGetContents h+      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs+      callback $ map toCache (catMaybes pkgsOrPrefs)   where+    toCache :: PackageOrDep -> IndexCacheEntry     toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo     toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo     toCache (Dep d) = CachePreference d@@ -370,35 +457,37 @@  readPackageIndexCacheFile :: Package pkg                           => (PackageEntry -> pkg)-                          -> FilePath-                          -> FilePath-                          -> ReadPackageIndexMode+                          -> Index                           -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do-  cache    <- liftM readIndexCache (BSS.readFile cacheFile)-  myWithFile indexFile ReadMode $ \indexHnd ->-    packageIndexFromCache mkPkg indexHnd cache mode-  where-    myWithFile f m act = case mode of-      ReadPackageIndexStrict -> withFile f m act-      ReadPackageIndexLazyIO -> do indexHnd <- openFile f m-                                   act indexHnd-+readPackageIndexCacheFile mkPkg index = do+  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)+  indexHnd <- openFile (indexFile index) ReadMode+  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO  packageIndexFromCache :: Package pkg                       => (PackageEntry -> pkg)                       -> Handle-                      -> [IndexCacheEntry]+                      -> Cache                       -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs+packageIndexFromCache mkPkg hnd cache mode = do+     (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode+     pkgIndex <- evaluate $ PackageIndex.fromList pkgs+     return (pkgIndex, prefs)++-- | Read package list+--+-- The result packages (though not the preferences) are guaranteed to be listed+-- in the same order as they are in the tar file (because later entries in a tar+-- file mask earlier ones).+packageListFromCache :: (PackageEntry -> pkg)+                     -> Handle+                     -> Cache+                     -> ReadPackageIndexMode+                     -> IO ([pkg], [Dependency])+packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries   where-    accum srcpkgs prefs [] = do-      -- Have to reverse entries, since in a tar file, later entries mask-      -- earlier ones, and PackageIndex.fromList does the same, but we-      -- accumulate the list of entries in reverse order, so need to reverse.-      pkgIndex <- evaluate $ PackageIndex.fromList (reverse srcpkgs)-      return (pkgIndex, prefs)+    accum srcpkgs prefs [] = return (reverse srcpkgs, prefs)      accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do       -- Given the cache entry, make a package index entry.@@ -433,22 +522,13 @@      getEntryContent :: BlockNo -> IO ByteString     getEntryContent blockno = do-      hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))-      header  <- BS.hGet hnd 512-      size    <- getEntrySize header-      BS.hGet hnd (fromIntegral size)--    getEntrySize :: ByteString -> IO Tar.FileSize-    getEntrySize header =-      case Tar.read header of-        Tar.Next e _ ->-          case Tar.entryContent e of-            Tar.NormalFile _ size -> return size-            Tar.OtherEntryType typecode _ size-              | Tar.isBuildTreeRefTypeCode typecode-                                  -> return size-            _                     -> interror "unexpected tar entry type"-        _ -> interror "could not read tar file entry"+      entry <- Tar.hReadEntry hnd blockno+      case Tar.entryContent entry of+        Tar.NormalFile content _size -> return content+        Tar.OtherEntryType typecode content _size+          | Tar.isBuildTreeRefTypeCode typecode+          -> return content+        _ -> interror "unexpected tar entry type"      readPackageDescription :: ByteString -> IO GenericPackageDescription     readPackageDescription content =@@ -467,15 +547,15 @@ -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. ---type BlockNo = Int+type BlockNo = Tar.TarEntryOffset  data IndexCacheEntry = CachePackageId PackageId BlockNo                      | CacheBuildTreeRef BuildTreeRefType BlockNo                      | CachePreference Dependency   deriving (Eq) -packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String-packageKey = "pkg:"+installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+installedUnitId = "pkg:" blocknoKey = "b#" buildTreeRefKey     = "build-tree-ref:" preferredVersionKey = "pref-ver:"@@ -484,7 +564,7 @@ readIndexCacheEntry = \line ->   case BSS.words line of     [key, pkgnamestr, pkgverstr, sep, blocknostr]-      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->+      | key == BSS.pack installedUnitId && sep == BSS.pack blocknoKey ->       case (parseName pkgnamestr, parseVer pkgverstr [],             parseBlockNo blocknostr) of         (Just pkgname, Just pkgver, Just blockno)@@ -515,8 +595,9 @@      parseBlockNo str =       case BSS.readInt str of-        Just (blockno, remainder) | BSS.null remainder -> Just blockno-        _                                              -> Nothing+        Just (blockno, remainder)+          | BSS.null remainder -> Just (fromIntegral blockno)+        _                      -> Nothing      parseRefType str =       case BSS.uncons str of@@ -527,7 +608,7 @@  showIndexCacheEntry :: IndexCacheEntry -> String showIndexCacheEntry entry = unwords $ case entry of-   CachePackageId pkgid b -> [ packageKey+   CachePackageId pkgid b -> [ installedUnitId                              , display (packageName pkgid)                              , display (packageVersion pkgid)                              , blocknoKey@@ -541,8 +622,15 @@                              , display dep                              ] -readIndexCache :: BSS.ByteString -> [IndexCacheEntry]-readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines+-- | Cabal caches various information about the Hackage index+data Cache = Cache {+    cacheEntries :: [IndexCacheEntry]+  } -showIndexCache :: [IndexCacheEntry] -> String-showIndexCache = unlines . map showIndexCacheEntry+readIndexCache :: BSS.ByteString -> Cache+readIndexCache bs = Cache {+    cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs+  }++showIndexCache :: Cache -> String+showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries
cabal/cabal-install/Distribution/Client/Init.hs view
@@ -18,6 +18,8 @@      -- * Commands     initCabal+  , pvpize+  , incVersion    ) where @@ -98,19 +100,21 @@ import Distribution.Client.IndexUtils   ( getSourcePackages ) import Distribution.Client.Types-  ( SourcePackageDb(..), Repo )+  ( SourcePackageDb(..) )+import Distribution.Client.Setup+  ( RepoContext(..) )  initCabal :: Verbosity           -> PackageDBStack-          -> [Repo]+          -> RepoContext           -> Compiler           -> ProgramConfiguration           -> InitFlags           -> IO ()-initCabal verbosity packageDBs repos comp conf initFlags = do+initCabal verbosity packageDBs repoCtxt comp conf initFlags = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-  sourcePkgDb <- getSourcePackages verbosity repos+  sourcePkgDb <- getSourcePackages verbosity repoCtxt    hSetBuffering stdout NoBuffering @@ -359,7 +363,7 @@ getSrcDir flags = do   srcDirs <- return (sourceDirs flags)              ?>> fmap (:[]) `fmap` guessSourceDir flags-             ?>> fmap (fmap ((:[]) . either id id) . join) (maybePrompt+             ?>> fmap (>>= fmap ((:[]) . either id id)) (maybePrompt                       flags                       (promptListOptional' "Source directory" ["src"] id)) @@ -465,12 +469,17 @@       return $ P.Dependency (P.pkgName . head $ pids)                             (pvpize . maximum . map P.pkgVersion $ pids) -    pvpize :: Version -> VersionRange-    pvpize v = orLaterVersion v'-               `intersectVersionRanges`-               earlierVersion (incVersion 1 v')-      where v' = (v { versionBranch = take 2 (versionBranch v) })+-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- Example: @0.4.1@ produces the version range @>= 0.4 && < 0.5@ (which is the+-- same as @0.4.*@).+pvpize :: Version -> VersionRange+pvpize v = orLaterVersion v'+           `intersectVersionRanges`+           earlierVersion (incVersion 1 v')+  where v' = (v { versionBranch = take 2 (versionBranch v) }) +-- | Increment the nth version component (counting from 0). incVersion :: Int -> Version -> Version incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags   where
cabal/cabal-install/Distribution/Client/Init/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Types@@ -17,6 +18,7 @@ import Distribution.Simple.Setup   ( Flag(..) ) +import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity import qualified Distribution.Package as P@@ -28,9 +30,7 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Text -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif+import GHC.Generics ( Generic )  -- | InitFlags is really just a simple type to represent certain --   portions of a .cabal file.  Rather than have a flag for EVERY@@ -71,7 +71,7 @@               , initVerbosity :: Flag Verbosity               , overwrite     :: Flag Bool               }-  deriving (Show)+  deriving (Show, Generic)    -- the Monoid instance for Flag has later values override earlier   -- ones, which is why we want Maybe [foo] for collecting foo values,@@ -85,63 +85,11 @@   parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]  instance Monoid InitFlags where-  mempty = InitFlags-    { nonInteractive = mempty-    , quiet          = mempty-    , packageDir     = mempty-    , noComments     = mempty-    , minimal        = mempty-    , packageName    = mempty-    , version        = mempty-    , cabalVersion   = mempty-    , license        = mempty-    , author         = mempty-    , email          = mempty-    , homepage       = mempty-    , synopsis       = mempty-    , category       = mempty-    , extraSrc       = mempty-    , packageType    = mempty-    , mainIs         = mempty-    , language       = mempty-    , exposedModules = mempty-    , otherModules   = mempty-    , otherExts      = mempty-    , dependencies   = mempty-    , sourceDirs     = mempty-    , buildTools     = mempty-    , initVerbosity  = mempty-    , overwrite      = mempty-    }-  mappend  a b = InitFlags-    { nonInteractive = combine nonInteractive-    , quiet          = combine quiet-    , packageDir     = combine packageDir-    , noComments     = combine noComments-    , minimal        = combine minimal-    , packageName    = combine packageName-    , version        = combine version-    , cabalVersion   = combine cabalVersion-    , license        = combine license-    , author         = combine author-    , email          = combine email-    , homepage       = combine homepage-    , synopsis       = combine synopsis-    , category       = combine category-    , extraSrc       = combine extraSrc-    , packageType    = combine packageType-    , mainIs         = combine mainIs-    , language       = combine language-    , exposedModules = combine exposedModules-    , otherModules   = combine otherModules-    , otherExts      = combine otherExts-    , dependencies   = combine dependencies-    , sourceDirs     = combine sourceDirs-    , buildTools     = combine buildTools-    , initVerbosity  = combine initVerbosity-    , overwrite      = combine overwrite-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>)++instance Semigroup InitFlags where+  (<>) = gmappend  -- | Some common package categories. data Category
cabal/cabal-install/Distribution/Client/Install.hs view
@@ -33,6 +33,7 @@          ( traverse_ ) import Data.List          ( isPrefixOf, unfoldr, nub, sort, (\\) )+import qualified Data.Map as Map import qualified Data.Set as S import Data.Maybe          ( catMaybes, isJust, isNothing, fromMaybe, mapMaybe )@@ -73,14 +74,14 @@          ( Solver(..), ConstraintSource(..), LabeledPackageConstraint(..) ) import Distribution.Client.FetchUtils import Distribution.Client.HttpUtils-         ( configureTransport, HttpTransport (..) )+         ( HttpTransport (..) ) import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup-         ( GlobalFlags(..)+         ( GlobalFlags(..), RepoContext(..)          , ConfigFlags(..), configureCommand, filterConfigureFlags          , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config@@ -118,9 +119,12 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Simple.LocalBuildInfo (ComponentName(CLibName))+import qualified Distribution.Simple.Configure as Configure import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags+         , AllowNewer(..)          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal          ( Flag(..)@@ -135,16 +139,18 @@          , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package          ( PackageIdentifier(..), PackageId, packageName, packageVersion-         , Package(..), LibraryName+         , Package(..)          , Dependency(..), thisPackageVersion-         , InstalledPackageId, installedPackageId-         , HasInstalledPackageId(..) )+         , UnitId(..), mkUnitId+         , HasUnitId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription          ( PackageDescription, GenericPackageDescription(..), Flag(..)          , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePackageDescription )+import Distribution.Client.PkgConfigDb+         ( PkgConfigDb, readPkgConfigDb ) import Distribution.ParseUtils          ( showPWarning ) import Distribution.Version@@ -153,7 +159,7 @@          ( notice, info, warn, debug, debugNoWrap, die          , intercalate, withTempDirectory ) import Distribution.Client.Utils-         ( determineNumJobs, inDir, mergeBy, MergeResult(..)+         ( determineNumJobs, inDir, logDirChange, mergeBy, MergeResult(..)          , tryCanonicalizePath ) import Distribution.System          ( Platform, OS(Windows), buildOS )@@ -184,7 +190,7 @@ install   :: Verbosity   -> PackageDBStack-  -> [Repo]+  -> RepoContext   -> Compiler   -> Platform   -> ProgramConfiguration@@ -230,14 +236,15 @@ -- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( InstalledPackageIndex, SourcePackageDb-                      , [UserTarget], [PackageSpecifier SourcePackage]+                      , PkgConfigDb+                      , [UserTarget], [PackageSpecifier UnresolvedSourcePackage]                       , HttpTransport )  -- TODO: Make InstallArgs a proper data type with documented fields or just get -- rid of it completely. -- | Initial arguments given to 'install' or 'makeInstallContext'. type InstallArgs = ( PackageDBStack-                   , [Repo]+                   , RepoContext                    , Compiler                    , Platform                    , ProgramConfiguration@@ -253,15 +260,16 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]                       -> IO InstallContext makeInstallContext verbosity-  (packageDBs, repos, comp, _, conf,_,_,+  (packageDBs, repoCtxt, comp, _, conf,_,_,    globalFlags, _, configExFlags, _, _) mUserTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity conf+     checkConfigExFlags verbosity installedPkgIndex                        (packageIndex sourcePkgDb) configExFlags-    transport <- configureTransport verbosity-                 (flagToMaybe (globalHttpTransport globalFlags))+    transport <- repoContextGetTransport repoCtxt      (userTargets, pkgSpecifiers) <- case mUserTargets of       Nothing           ->@@ -275,13 +283,13 @@         let userTargets | null userTargets0 = [UserTargetLocalDir "."]                         | otherwise         = userTargets0 -        pkgSpecifiers <- resolveUserTargets verbosity transport+        pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                          (fromFlag $ globalWorldFile globalFlags)                          (packageIndex sourcePkgDb)                          userTargets         return (userTargets, pkgSpecifiers) -    return (installedPkgIndex, sourcePkgDb, userTargets+    return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets            ,pkgSpecifiers, transport)  -- | Make an install plan given install context and install arguments.@@ -291,7 +299,7 @@   (_, _, comp, platform, _, _, mSandboxPkgInfo,    _, configFlags, configExFlags, installFlags,    _)-  (installedPkgIndex, sourcePkgDb,+  (installedPkgIndex, sourcePkgDb, pkgConfigDb,    _, pkgSpecifiers, _) = do      solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))@@ -299,7 +307,7 @@     notice verbosity "Resolving dependencies..."     return $ planPackages comp platform mSandboxPkgInfo solver       configFlags configExFlags installFlags-      installedPkgIndex sourcePkgDb pkgSpecifiers+      installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers  -- | Given an install plan, perform the actual installations. processInstallPlan :: Verbosity -> InstallArgs -> InstallContext@@ -307,7 +315,7 @@                    -> IO () processInstallPlan verbosity   args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)-  (installedPkgIndex, sourcePkgDb,+  (installedPkgIndex, sourcePkgDb, _,    userTargets, pkgSpecifiers, _) installPlan = do     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers@@ -333,14 +341,15 @@              -> InstallFlags              -> InstalledPackageIndex              -> SourcePackageDb-             -> [PackageSpecifier SourcePackage]+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]              -> Progress String String InstallPlan planPackages comp platform mSandboxPkgInfo solver              configFlags configExFlags installFlags-             installedPkgIndex sourcePkgDb pkgSpecifiers =+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =          resolveDependencies-          platform (compilerInfo comp)+          platform (compilerInfo comp) pkgConfigDb           solver           resolverParams @@ -400,23 +409,22 @@       $ standardInstallPolicy         installedPkgIndex sourcePkgDb pkgSpecifiers -    stanzas = concat-        [ if testsEnabled then [TestStanzas] else []-        , if benchmarksEnabled then [BenchStanzas] else []-        ]-    testsEnabled = fromFlagOrDefault False $ configTests configFlags+    stanzas           = [ TestStanzas | testsEnabled ]+                     ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ configTests configFlags     benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags -    reinstall        = fromFlag (installReinstall        installFlags)-    reorderGoals     = fromFlag (installReorderGoals     installFlags)-    independentGoals = fromFlag (installIndependentGoals installFlags)-    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)-    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)-    strongFlags      = fromFlag (installStrongFlags      installFlags)-    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)-    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)-    onlyDeps         = fromFlag (installOnlyDeps         installFlags)-    allowNewer       = fromFlag (configAllowNewer        configExFlags)+    reinstall        = fromFlag (installOverrideReinstall installFlags) ||+                       fromFlag (installReinstall         installFlags)+    reorderGoals     = fromFlag (installReorderGoals      installFlags)+    independentGoals = fromFlag (installIndependentGoals  installFlags)+    avoidReinstalls  = fromFlag (installAvoidReinstalls   installFlags)+    shadowPkgs       = fromFlag (installShadowPkgs        installFlags)+    strongFlags      = fromFlag (installStrongFlags       installFlags)+    maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)+    upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)+    onlyDeps         = fromFlag (installOnlyDeps          installFlags)+    allowNewer       = fromMaybe AllowNewerNone (configAllowNewer configFlags)  -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg@@ -459,7 +467,7 @@                -> InstallPlan                -> SourcePackageDb                -> InstallFlags-               -> [PackageSpecifier SourcePackage]+               -> [PackageSpecifier UnresolvedSourcePackage]                -> IO () checkPrintPlan verbosity installed installPlan sourcePkgDb   installFlags pkgSpecifiers = do@@ -483,16 +491,16 @@   let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan   -- Packages that are already broken.   let oldBrokenPkgs =-          map Installed.installedPackageId+          map Installed.installedUnitId         . PackageIndex.reverseDependencyClosure installed-        . map (Installed.installedPackageId . fst)+        . map (Installed.installedUnitId . fst)         . PackageIndex.brokenPackages         $ installed   let excluded = reinstalledPkgs ++ oldBrokenPkgs   -- Packages that are reverse dependencies of replaced packages are very   -- likely to be broken. We exclude packages that are already broken.   let newBrokenPkgs =-        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))+        filter (\ p -> not (Installed.installedUnitId p `elem` excluded))                (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)   let containsReinstalls = not (null reinstalledPkgs)   let breaksPkgs         = not (null newBrokenPkgs)@@ -529,9 +537,8 @@   -- are already fetched.   let offline = fromFlagOrDefault False (installOfflineMode installFlags)   when offline $ do-    let pkgs = [ sourcePkg-               | InstallPlan.Configured (ConfiguredPackage sourcePkg _ _ _)-                 <- InstallPlan.toList installPlan ]+    let pkgs = [ confPkgSource cpkg+               | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]     notFetched <- fmap (map packageInfoId)                   . filterM (fmap isNothing . checkFetched . packageSource)                   $ pkgs@@ -547,7 +554,14 @@     dryRun            = fromFlag (installDryRun            installFlags)     overrideReinstall = fromFlag (installOverrideReinstall installFlags) ---TODO: this type is too specific+-- | Given an 'InstallPlan', perform a dry run, producing the sequence+-- of 'ReadyPackage's which would be compiled in order to carry+-- out this plan.  This function is not actually used to execute a plan;+-- presently, it is used only to (1) determine if the installation+-- plan would cause reinstalls and (2) to print out what would be+-- installed.+--+-- TODO: this type is too specific linearizeInstallPlan :: InstalledPackageIndex                      -> InstallPlan                      -> [(ReadyPackage, PackageStatus)]@@ -558,11 +572,11 @@       []      -> Nothing       (pkg:_) -> Just ((pkg, status), plan'')         where-          pkgid  = installedPackageId pkg+          pkgid  = installedUnitId pkg           status = packageStatus installedPkgIndex pkg           ipkg   = Installed.emptyInstalledPackageInfo {-                     Installed.sourcePackageId    = packageId pkg,-                     Installed.installedPackageId = pkgid+                     Installed.sourcePackageId = packageId pkg,+                     Installed.installedUnitId = pkgid                    }           plan'' = InstallPlan.completed pkgid (Just ipkg)                      (BuildOk DocsNotTried TestsNotTried (Just ipkg))@@ -570,15 +584,16 @@           --FIXME: This is a bit of a hack,           -- pretending that each package is installed           -- It's doubly a hack because the installed package ID-          -- didn't get updated...+          -- didn't get updated.  But it doesn't really matter+          -- because we're not going to use this for anything real.  data PackageStatus = NewPackage                    | NewVersion [Version]-                   | Reinstall  [InstalledPackageId] [PackageChange]+                   | Reinstall  [UnitId] [PackageChange]  type PackageChange = MergeResult PackageIdentifier PackageIdentifier -extractReinstalls :: PackageStatus -> [InstalledPackageId]+extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = [] @@ -592,7 +607,7 @@     ps ->  case filter ((== packageId cpkg)                         . Installed.sourcePackageId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)-      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)+      pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)                                 (changes pkg cpkg)    where@@ -608,13 +623,13 @@         (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))      -- convert to source pkg ids via index-    resolveInstalledIds :: [InstalledPackageId] -> [PackageIdentifier]+    resolveInstalledIds :: [UnitId] -> [PackageIdentifier]     resolveInstalledIds =         nub       . sort       . map Installed.sourcePackageId       . catMaybes-      . map (PackageIndex.lookupInstalledPackageId installedPkgIndex)+      . map (PackageIndex.lookupUnitId installedPkgIndex)      changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True@@ -627,7 +642,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of   []   -> return ()   pkgs-    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+    | verbosity >= Verbosity.verbose -> putStr $ unlines $         ("In order, the following " ++ wouldWill ++ " be installed:")       : map showPkgAndReason pkgs     | otherwise -> notice verbosity $ unlines $@@ -641,16 +656,18 @@     showPkg (pkg, _) = display (packageId pkg) ++                        showLatest (pkg) -    showPkgAndReason (ReadyPackage pkg' _, pr) = display (packageId pkg') +++    showPkgAndReason (ReadyPackage pkg', pr) = display (packageId pkg') ++           showLatest pkg' ++           showFlagAssignment (nonDefaultFlags pkg') ++-          showStanzas (stanzas pkg') ++ " " +++          showStanzas (confPkgStanzas pkg') +++          showDep pkg' ++           case pr of-            NewPackage     -> "(new package)"-            NewVersion _   -> "(new version)"-            Reinstall _ cs -> "(reinstall)" ++ case cs of+            NewPackage     -> " (new package)"+            NewVersion _   -> " (new version)"+            Reinstall _ cs -> " (reinstall)" ++ case cs of                 []   -> ""-                diff -> " changes: "  ++ intercalate ", " (map change diff)+                diff -> " (changes: "  ++ intercalate ", " (map change diff)+                        ++ ")"      showLatest :: Package srcpkg => srcpkg -> String     showLatest pkg = case mLatestVersion of@@ -670,22 +687,18 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment-    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+    nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment+    nonDefaultFlags cpkg =       let defaultAssignment =             toFlagAssignment-             (genPackageFlags (Source.packageDescription spkg))-      in  fa \\ defaultAssignment--    stanzas :: ConfiguredPackage -> [OptionalStanza]-    stanzas (ConfiguredPackage _ _ sts _) = sts+             (genPackageFlags (Source.packageDescription (confPkgSource cpkg)))+      in  confPkgFlags cpkg \\ defaultAssignment      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((' ' :) . showStanza)     showStanza TestStanzas  = "*test"     showStanza BenchStanzas = "*bench" -    -- FIXME: this should be a proper function in a proper place     showFlagAssignment :: FlagAssignment -> String     showFlagAssignment = concatMap ((' ' :) . showFlagValue)     showFlagValue (f, True)   = '+' : showFlagName f@@ -697,6 +710,18 @@                                     ++ display (packageVersion pkgid')     change (OnlyInRight      pkgid') = display pkgid' ++ " added" +    showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps+                  = " (via: " ++ unwords (map display rdeps) ++  ")"+                | otherwise = ""++    revDepGraphEdges :: [(PackageId, PackageId)]+    revDepGraphEdges = [ (rpid, packageId cpkg)+                       | (ReadyPackage cpkg, _) <- plan+                       , ConfiguredId rpid _ <- CD.flatDeps (confPkgDeps cpkg) ]++    revDeps :: Map.Map PackageId [PackageId]+    revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)+ -- ------------------------------------------------------------ -- * Post installation stuff -- ------------------------------------------------------------@@ -708,7 +733,7 @@ reportPlanningFailure verbosity   (_, _, comp, platform, _, _, _   ,_, configFlags, _, installFlags, _)-  (_, sourcePkgDb, _, pkgSpecifiers, _)+  (_, sourcePkgDb, _, _, pkgSpecifiers, _)   message = do    when reportFailure $ do@@ -736,7 +761,7 @@     case logFile of       Nothing -> return ()       Just template -> forM_ pkgids $ \pkgid ->-        let env = initialPathTemplateEnv pkgid dummyLibraryName+        let env = initialPathTemplateEnv pkgid dummyIpid                     (compilerInfo comp) platform             path = fromPathTemplate $ substPathTemplate env template         in  writeFile path message@@ -745,10 +770,10 @@     reportFailure = fromFlag (installReportPlanningFailure installFlags)     logFile = flagToMaybe (installLogFile installFlags) -    -- A LibraryName is calculated from the transitive closure of+    -- A IPID is calculated from the transitive closure of     -- dependencies, but when the solver fails we don't have that.     -- So we fail.-    dummyLibraryName = error "reportPlanningFailure: library name not available"+    dummyIpid = error "reportPlanningFailure: installed package ID not available"  -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package.@@ -836,7 +861,8 @@          createDirectoryIfMissing True reportsDir -- FIXME          writeFile reportFile (show (BuildReports.show report, buildLog)) -  | (report, Just Repo { repoKind = Left remoteRepo }) <- reports+  | (report, Just repo) <- reports+  , Just remoteRepo <- [maybeRepoRemote repo]   , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]    where@@ -1003,7 +1029,7 @@   withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do     let allInstalled = [ pkg | InstallPlan.Installed pkg _ _                             <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ pkg | ReadyPackage (ConfiguredPackage pkg _ _ _) _+        allSrcPkgs   = [ confPkgSource cpkg | ReadyPackage cpkg                             <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]@@ -1023,7 +1049,7 @@  -- | If logging is enabled, contains location of the log file and the verbosity -- level for logging.-type UseLogFile = Maybe (PackageIdentifier -> LibraryName -> FilePath, Verbosity)+type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)  performInstallations :: Verbosity                      -> InstallArgs@@ -1031,7 +1057,7 @@                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity-  (packageDBs, _, comp, platform, conf, useSandbox, _,+  (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do @@ -1048,23 +1074,18 @@   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  transport <- configureTransport verbosity-               (flagToMaybe (globalHttpTransport globalFlags))-   executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg ->-    -- Calculate the package key (ToDo: Is this right for source install)-    let libname = readyLibraryName comp rpkg in     installReadyPackage platform cinfo configFlags                         rpkg $ \configFlags' src pkg pkgoverride ->-      fetchSourcePackage transport verbosity fetchLimit src $ \src' ->+      fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->         installLocalPackage verbosity buildLimit                             (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity buildLimit installLock numJobs libname+          installUnpackedPackage verbosity buildLimit installLock numJobs                                  (setupScriptOptions installedPkgIndex                                   cacheLock rpkg)                                  miscOptions configFlags'                                  installFlags haddockFlags-                                 cinfo platform pkg pkgoverride mpath useLogFile+                                 cinfo platform pkg rpkg pkgoverride mpath useLogFile    where     cinfo = compilerInfo comp@@ -1082,7 +1103,7 @@         platform         conf         distPref-        (chooseCabalVersion configExFlags (libVersion miscOptions))+        (chooseCabalVersion configFlags (libVersion miscOptions))         (Just lock)         parallelInstall         index@@ -1128,12 +1149,12 @@           | parallelInstall                   = False           | otherwise                         = False -    substLogFileName :: PathTemplate -> PackageIdentifier -> LibraryName-                     -> FilePath-    substLogFileName template pkg libname = fromPathTemplate-                                          . substPathTemplate env-                                          $ template-      where env = initialPathTemplateEnv (packageId pkg) libname+    substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath+    substLogFileName template pkg ipid = fromPathTemplate+                                  . substPathTemplate env+                                  $ template+      where env = initialPathTemplateEnv (packageId pkg)+                  ipid                   (compilerInfo comp) platform      miscOptions  = InstallMisc {@@ -1148,12 +1169,12 @@  executeInstallPlan :: Verbosity                    -> Compiler-                   -> JobControl IO (PackageId, LibraryName, BuildResult)+                   -> JobControl IO (PackageId, UnitId, BuildResult)                    -> UseLogFile                    -> InstallPlan                    -> (ReadyPackage -> IO BuildResult)                    -> IO InstallPlan-executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg =+executeInstallPlan verbosity _comp jobCtl useLogFile plan0 installPkg =     tryNewTasks 0 plan0   where     tryNewTasks taskCount plan = do@@ -1165,10 +1186,13 @@             [ do info verbosity $ "Ready to install " ++ display pkgid                  spawnJob jobCtl $ do                    buildResult <- installPkg pkg-                   return (packageId pkg, libname, buildResult)+                   let ipid = case buildResult of+                                Right (BuildOk _ _ (Just ipi)) ->+                                     Installed.installedUnitId ipi+                                _ -> mkUnitId (display (packageId pkg))+                   return (packageId pkg, ipid, buildResult)             | pkg <- pkgs-            , let pkgid = packageId pkg-                  libname = readyLibraryName comp pkg ]+            , let pkgid = packageId pkg ]            let taskCount' = taskCount + length pkgs               plan'      = InstallPlan.processing pkgs plan@@ -1176,8 +1200,8 @@      waitForTasks taskCount plan = do       info verbosity $ "Waiting for install task to finish..."-      (pkgid, libname, buildResult) <- collectJob jobCtl-      printBuildResult pkgid libname buildResult+      (pkgid, ipid, buildResult) <- collectJob jobCtl+      printBuildResult pkgid ipid buildResult       let taskCount' = taskCount-1           plan'      = updatePlan pkgid buildResult plan       tryNewTasks taskCount' plan'@@ -1185,11 +1209,11 @@     updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan                -> InstallPlan     updatePlan pkgid (Right buildSuccess@(BuildOk _ _ mipkg)) =-        InstallPlan.completed (Source.fakeInstalledPackageId pkgid)+        InstallPlan.completed (Source.fakeUnitId pkgid)                               mipkg buildSuccess      updatePlan pkgid (Left buildFailure) =-        InstallPlan.failed (Source.fakeInstalledPackageId pkgid)+        InstallPlan.failed (Source.fakeUnitId pkgid)                            buildFailure depsFailure       where         depsFailure = DependentFailed pkgid@@ -1200,8 +1224,8 @@      -- Print build log if something went wrong, and 'Installed $PKGID'     -- otherwise.-    printBuildResult :: PackageId -> LibraryName -> BuildResult -> IO ()-    printBuildResult pkgid libname buildResult = case buildResult of+    printBuildResult :: PackageId -> UnitId -> BuildResult -> IO ()+    printBuildResult pkgid ipid buildResult = case buildResult of         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid@@ -1209,7 +1233,7 @@             case useLogFile of               Nothing                 -> return ()               Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid libname+                let logName = mkLogFileName pkgid ipid                 putStr $ "Build log ( " ++ logName ++ " ):\n"                 printFile logName @@ -1227,7 +1251,7 @@ installReadyPackage :: Platform -> CompilerInfo                     -> ConfigFlags                     -> ReadyPackage-                    -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                    -> (ConfigFlags -> UnresolvedPkgLoc                                     -> PackageDescription                                     -> PackageDescriptionOverride                                     -> a)@@ -1235,19 +1259,17 @@ installReadyPackage platform cinfo configFlags                     (ReadyPackage (ConfiguredPackage                                     (SourcePackage _ gpkg source pkgoverride)-                                    flags stanzas _)-                                   deps)+                                    flags stanzas deps))                     installPkg =   installPkg configFlags {     configConfigurationsFlags = flags,     -- We generate the legacy constraints as well as the new style precise deps.     -- In the end only one set gets passed to Setup.hs configure, depending on     -- the Cabal version we are talking to.-    configConstraints  = [ thisPackageVersion (packageId deppkg)-                         | deppkg <- CD.nonSetupDeps deps ],-    configDependencies = [ (packageName (Installed.sourcePackageId deppkg),-                            Installed.installedPackageId deppkg)-                         | deppkg <- CD.nonSetupDeps deps ],+    configConstraints  = [ thisPackageVersion srcid+                         | ConfiguredId srcid _uid <- CD.nonSetupDeps deps ],+    configDependencies = [ (packageName srcid, uid)+                         | ConfiguredId srcid uid <- CD.nonSetupDeps deps ],     -- Use '--exact-configuration' if supported.     configExactConfiguration = toFlag True,     configBenchmarks         = toFlag False,@@ -1261,26 +1283,26 @@       Right (desc, _) -> desc  fetchSourcePackage-  :: HttpTransport-  -> Verbosity+  :: Verbosity+  -> RepoContext   -> JobLimit-  -> PackageLocation (Maybe FilePath)-  -> (PackageLocation FilePath -> IO BuildResult)+  -> UnresolvedPkgLoc+  -> (ResolvedPkgLoc -> IO BuildResult)   -> IO BuildResult-fetchSourcePackage transport verbosity fetchLimit src installPkg = do+fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do   fetched <- checkFetched src   case fetched of     Just src' -> installPkg src'     Nothing   -> onFailure DownloadFailed $ do                    loc <- withJobLimit fetchLimit $-                            fetchPackage transport verbosity src+                            fetchPackage verbosity repoCtxt src                    installPkg loc   installLocalPackage   :: Verbosity   -> JobLimit-  -> PackageIdentifier -> PackageLocation FilePath -> FilePath+  -> PackageIdentifier -> ResolvedPkgLoc -> FilePath   -> (Maybe FilePath -> IO BuildResult)   -> IO BuildResult installLocalPackage verbosity jobLimit pkgid location distPref installPkg =@@ -1362,7 +1384,6 @@   -> JobLimit   -> Lock   -> Int-  -> LibraryName   -> SetupScriptOptions   -> InstallMisc   -> ConfigFlags@@ -1371,14 +1392,15 @@   -> CompilerInfo   -> Platform   -> PackageDescription+  -> ReadyPackage   -> PackageDescriptionOverride   -> Maybe FilePath -- ^ Directory to change to before starting the installation.   -> UseLogFile -- ^ File to log output to (if any)   -> IO BuildResult-installUnpackedPackage verbosity buildLimit installLock numJobs libname+installUnpackedPackage verbosity buildLimit installLock numJobs                        scriptOptions miscOptions                        configFlags installFlags haddockFlags-                       cinfo platform pkg pkgoverride workingDir useLogFile = do+                       cinfo platform pkg rpkg pkgoverride workingDir useLogFile = do    -- Override the .cabal file if necessary   case pkgoverride of@@ -1391,9 +1413,20 @@                     ++ " with the latest revision from the index."       writeFileAtomic descFilePath pkgtxt +  -- Compute the IPID of the *library*+  let flags (ReadyPackage cpkg) = confPkgFlags cpkg+      pkg_name = pkgName (PackageDescription.package pkg)+      cid = Configure.computeComponentId+                Cabal.NoFlag -- This would let us override the computation+                (PackageDescription.package pkg)+                (CLibName (display pkg_name))+                (map (\(SimpleUnitId cid0) -> cid0) (CD.libraryDeps (depends rpkg)))+                (flags rpkg)+      ipid = SimpleUnitId cid+   -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if   -- the setup script was compiled against an old version of the Cabal lib).-  configFlags' <- addDefaultInstallDirs configFlags+  configFlags' <- addDefaultInstallDirs ipid configFlags   -- Filter out flags not supported by the old versions of the Cabal lib.   let configureFlags :: Version -> ConfigFlags       configureFlags  = filterConfigureFlags configFlags' {@@ -1401,52 +1434,55 @@       }    -- Path to the optional log file.-  mLogPath <- maybeLogPath--  -- Configure phase-  onFailure ConfigureFailed $ withJobLimit buildLimit $ do-    when (numJobs > 1) $ notice verbosity $-      "Configuring " ++ display pkgid ++ "..."-    setup configureCommand configureFlags mLogPath+  mLogPath <- maybeLogPath ipid -  -- Build phase-    onFailure BuildFailed $ do+  logDirChange (maybe putStr appendFile mLogPath) workingDir $ do+    -- Configure phase+    onFailure ConfigureFailed $ withJobLimit buildLimit $ do       when (numJobs > 1) $ notice verbosity $-        "Building " ++ display pkgid ++ "..."-      setup buildCommand' buildFlags mLogPath+        "Configuring " ++ display pkgid ++ "..."+      setup configureCommand configureFlags mLogPath -  -- Doc generation phase-      docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags' mLogPath-                 return DocsOk)-               `catchIO`   (\_ -> return DocsFailed)-               `catchExit` (\_ -> return DocsFailed)-        else return DocsNotTried+    -- Build phase+      onFailure BuildFailed $ do+        when (numJobs > 1) $ notice verbosity $+          "Building " ++ display pkgid ++ "..."+        setup buildCommand' buildFlags mLogPath -  -- Tests phase-      onFailure TestsFailed $ do-        when (testsEnabled && PackageDescription.hasTests pkg) $-            setup Cabal.testCommand testFlags mLogPath+    -- Doc generation phase+        docsResult <- if shouldHaddock+          then (do setup haddockCommand haddockFlags' mLogPath+                   return DocsOk)+                 `catchIO`   (\_ -> return DocsFailed)+                 `catchExit` (\_ -> return DocsFailed)+          else return DocsNotTried -        let testsResult | testsEnabled = TestsOk-                        | otherwise = TestsNotTried+    -- Tests phase+        onFailure TestsFailed $ do+          when (testsEnabled && PackageDescription.hasTests pkg) $+              setup Cabal.testCommand testFlags mLogPath -      -- Install phase-        onFailure InstallFailed $ criticalSection installLock $ do-          -- Capture installed package configuration file-          maybePkgConf <- maybeGenPkgConf mLogPath+          let testsResult | testsEnabled = TestsOk+                          | otherwise = TestsNotTried -          -- Actual installation-          withWin32SelfUpgrade verbosity libname configFlags-                               cinfo platform pkg $ do-            case rootCmd miscOptions of-              (Just cmd) -> reexec cmd-              Nothing    -> do-                setup Cabal.copyCommand copyFlags mLogPath-                when shouldRegister $ do-                  setup Cabal.registerCommand registerFlags mLogPath-          return (Right (BuildOk docsResult testsResult maybePkgConf))+        -- Install phase+          onFailure InstallFailed $ criticalSection installLock $ do+            -- Actual installation+            withWin32SelfUpgrade verbosity ipid configFlags+                                 cinfo platform pkg $ do+              case rootCmd miscOptions of+                (Just cmd) -> reexec cmd+                Nothing    -> do+                  setup Cabal.copyCommand copyFlags mLogPath+                  when shouldRegister $ do+                    setup Cabal.registerCommand registerFlags mLogPath +            -- Capture installed package configuration file+            -- TODO: Why do we need this?+            maybePkgConf <- maybeGenPkgConf mLogPath++            return (Right (BuildOk docsResult testsResult maybePkgConf))+   where     pkgid            = packageId pkg     buildCommand'    = buildCommand defaultProgramConfiguration@@ -1477,8 +1513,8 @@     verbosity' = maybe verbosity snd useLogFile     tempTemplate name = name ++ "-" ++ display pkgid -    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags-    addDefaultInstallDirs configFlags' = do+    addDefaultInstallDirs :: UnitId -> ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs ipid configFlags' = do       defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False       return $ configFlags' {           configInstallDirs = fmap Cabal.Flag .@@ -1488,7 +1524,7 @@           }         where           CompilerId flavor _ = compilerInfoId cinfo-          env         = initialPathTemplateEnv pkgid libname cinfo platform+          env         = initialPathTemplateEnv pkgid ipid cinfo platform           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') @@ -1517,12 +1553,12 @@       die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"             ++ show perror -    maybeLogPath :: IO (Maybe FilePath)-    maybeLogPath =+    maybeLogPath :: UnitId -> IO (Maybe FilePath)+    maybeLogPath ipid =       case useLogFile of          Nothing                 -> return Nothing          Just (mkLogFileName, _) -> do-           let logFileName = mkLogFileName (packageId pkg) libname+           let logFileName = mkLogFileName (packageId pkg) ipid                logDir      = takeDirectory logFileName            unless (null logDir) $ createDirectoryIfMissing True logDir            logFileExists <- doesFileExist logFileName@@ -1570,14 +1606,14 @@ -- ------------------------------------------------------------  withWin32SelfUpgrade :: Verbosity-                     -> LibraryName+                     -> UnitId                      -> ConfigFlags                      -> CompilerInfo                      -> Platform                      -> PackageDescription                      -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity libname configFlags cinfo platform pkg action = do+withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1605,10 +1641,10 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid libname+                           pkgid ipid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid libname+          where env = InstallDirs.initialPathTemplateEnv pkgid ipid                       cinfo platform
cabal/cabal-install/Distribution/Client/InstallPlan.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.InstallPlan@@ -21,11 +22,16 @@   -- * Operations on 'InstallPlan's   new,   toList,+  mapPreservingGraph,+   ready,   processing,   completed,   failed,   remove,+  preexisting,+  preinstalled,+   showPlanIndex,   showInstallPlan, @@ -42,17 +48,21 @@    -- ** Querying the install plan   dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,   ) where  import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.Package          ( PackageIdentifier(..), PackageName(..), Package(..)-         , InstalledPackageId, HasInstalledPackageId(..) )+         , HasUnitId(..), UnitId(..) ) import Distribution.Client.Types          ( BuildSuccess, BuildFailure          , PackageFixedDeps(..), ConfiguredPackage-         , GenericReadyPackage(..), fakeInstalledPackageId )+         , UnresolvedPkgLoc+         , GenericReadyPackage(..), fakeUnitId ) import Distribution.Version          ( Version ) import Distribution.Client.ComponentDeps (ComponentDeps)@@ -67,14 +77,16 @@          ( 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+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 @@ -135,12 +147,16 @@ data GenericPlanPackage ipkg srcpkg iresult ifailure    = PreExisting ipkg    | Configured  srcpkg-   | Processing  (GenericReadyPackage srcpkg ipkg)-   | Installed   (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult+   | Processing  (GenericReadyPackage srcpkg)+   | Installed   (GenericReadyPackage srcpkg) (Maybe ipkg) iresult    | Failed      srcpkg ifailure+  deriving (Eq, Show, Generic) +instance (Binary ipkg, Binary srcpkg, Binary  iresult, Binary  ifailure)+      => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure)+ type PlanPackage = GenericPlanPackage-                   InstalledPackageInfo ConfiguredPackage+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)                    BuildSuccess BuildFailure  instance (Package ipkg, Package srcpkg) =>@@ -152,7 +168,7 @@   packageId (Failed      spkg   _) = packageId spkg  instance (PackageFixedDeps srcpkg,-          PackageFixedDeps ipkg, HasInstalledPackageId ipkg) =>+          PackageFixedDeps ipkg) =>          PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where   depends (PreExisting pkg)     = depends pkg   depends (Configured  pkg)     = depends pkg@@ -160,58 +176,114 @@   depends (Installed   pkg _ _) = depends pkg   depends (Failed      pkg   _) = depends pkg -instance (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg) =>-         HasInstalledPackageId+instance (HasUnitId ipkg, HasUnitId srcpkg) =>+         HasUnitId          (GenericPlanPackage ipkg srcpkg iresult ifailure) where-  installedPackageId (PreExisting ipkg ) = installedPackageId ipkg-  installedPackageId (Configured  spkg)  = installedPackageId spkg-  installedPackageId (Processing  rpkg)  = installedPackageId rpkg+  installedUnitId (PreExisting ipkg ) = installedUnitId ipkg+  installedUnitId (Configured  spkg)  = installedUnitId spkg+  installedUnitId (Processing  rpkg)  = installedUnitId rpkg   -- NB: defer to the actual installed package info in this case-  installedPackageId (Installed _ (Just ipkg) _) = installedPackageId ipkg-  installedPackageId (Installed rpkg _        _) = installedPackageId rpkg-  installedPackageId (Failed      spkg        _) = installedPackageId spkg+  installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg+  installedUnitId (Installed rpkg _        _) = installedUnitId rpkg+  installedUnitId (Failed      spkg        _) = installedUnitId spkg   data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {-    planIndex      :: (PlanIndex ipkg srcpkg iresult ifailure),-    planFakeMap    :: FakeMap,+    planIndex      :: !(PlanIndex ipkg srcpkg iresult ifailure),+    planFakeMap    :: !FakeMap,+    planIndepGoals :: !Bool,++    -- | Cached (lazily) graph+    --+    -- The 'Graph' representation works in terms of integer node ids, so we+    -- have to keep mapping to and from our meaningful nodes, which of course+    -- are package ids.+    --     planGraph      :: Graph,-    planGraphRev   :: Graph,-    planPkgOf      :: Graph.Vertex-                      -> GenericPlanPackage ipkg srcpkg iresult ifailure,-    planVertexOf   :: InstalledPackageId -> Graph.Vertex,-    planIndepGoals :: Bool+    planGraphRev   :: Graph,  -- ^ Reverse deps, transposed+    planPkgIdOf    :: Graph.Vertex -> UnitId, -- ^ mapping back to package ids+    planVertexOf   :: UnitId -> Graph.Vertex  -- ^ mapping into node ids   } +-- | Much like 'planPkgIdOf', but mapping back to full packages.+planPkgOf :: GenericInstallPlan ipkg srcpkg iresult ifailure+          -> Graph.Vertex+          -> GenericPlanPackage ipkg srcpkg iresult ifailure+planPkgOf plan v =+    case PackageIndex.lookupUnitId (planIndex plan)+                                   (planPkgIdOf plan v) of+      Just pkg -> pkg+      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"++ -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan-                   InstalledPackageInfo ConfiguredPackage+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)                    BuildSuccess BuildFailure  type PlanIndex ipkg srcpkg iresult ifailure =      PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure) -invariant :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-              HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+invariant :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+              HasUnitId srcpkg, PackageFixedDeps srcpkg)           => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool invariant plan =     valid (planFakeMap plan)           (planIndepGoals plan)           (planIndex plan) +-- | Smart constructor that deals with caching the 'Graph' representation.+--+mkInstallPlan :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+                  HasUnitId srcpkg, PackageFixedDeps srcpkg)+              => PlanIndex ipkg srcpkg iresult ifailure+              -> FakeMap+              -> Bool+              -> GenericInstallPlan ipkg srcpkg iresult ifailure+mkInstallPlan index fakeMap indepGoals =+    GenericInstallPlan {+      planIndex      = index,+      planFakeMap    = fakeMap,+      planIndepGoals = indepGoals,++      -- lazily cache the graph stuff:+      planGraph      = graph,+      planGraphRev   = Graph.transposeG graph,+      planPkgIdOf    = vertexToPkgId,+      planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex+    }+  where+    (graph, vertexToPkgId, pkgIdToVertex) =+      PlanIndex.dependencyGraph fakeMap index+    noSuchPkgId = internalError "package is not in the graph"+ internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg -showPlanIndex :: (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg)+instance (HasUnitId ipkg,   PackageFixedDeps ipkg,+          HasUnitId srcpkg, PackageFixedDeps srcpkg,+          Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure)+       => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where+    put GenericInstallPlan {+              planIndex      = index,+              planFakeMap    = fakeMap,+              planIndepGoals = indepGoals+        } = put (index, fakeMap, indepGoals)++    get = do+      (index, fakeMap, indepGoals) <- get+      return $! mkInstallPlan index fakeMap indepGoals++showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)               => PlanIndex ipkg srcpkg iresult ifailure -> String showPlanIndex index =     intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index))   where showPlanPackage p =             showPlanPackageTag p ++ " "                 ++ display (packageId p) ++ " ("-                ++ display (installedPackageId p) ++ ")"+                ++ display (installedUnitId p) ++ ")" -showInstallPlan :: (HasInstalledPackageId ipkg, HasInstalledPackageId srcpkg)+showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)                 => GenericInstallPlan ipkg srcpkg iresult ifailure -> String showInstallPlan plan =     showPlanIndex (planIndex plan) ++ "\n" ++@@ -228,8 +300,8 @@  -- | Build an installation plan from a valid set of resolved packages. ---new :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-        HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+new :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+        HasUnitId srcpkg, PackageFixedDeps srcpkg)     => Bool     -> PlanIndex ipkg srcpkg iresult ifailure     -> Either [PlanProblem ipkg srcpkg iresult ifailure]@@ -240,23 +312,12 @@   let isPreExisting (PreExisting _) = True       isPreExisting _ = False       fakeMap = Map.fromList-              . map (\p -> (fakeInstalledPackageId (packageId p)-                           ,installedPackageId p))+              . map (\p -> (fakeUnitId (packageId p)+                           ,installedUnitId p))               . filter isPreExisting               $ PackageIndex.allPackages index in   case problems fakeMap indepGoals index of-    [] -> Right GenericInstallPlan {-            planIndex      = index,-            planFakeMap    = fakeMap,-            planGraph      = graph,-            planGraphRev   = Graph.transposeG graph,-            planPkgOf      = vertexToPkgId,-            planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex,-            planIndepGoals = indepGoals-          }-      where (graph, vertexToPkgId, pkgIdToVertex) =-              PlanIndex.dependencyGraph fakeMap index-            noSuchPkgId = internalError "package is not in the graph"+    []    -> Right (mkInstallPlan index fakeMap indepGoals)     probs -> Left probs  toList :: GenericInstallPlan ipkg srcpkg iresult ifailure@@ -269,8 +330,8 @@ -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. ---remove :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-           HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+remove :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+           HasUnitId srcpkg, PackageFixedDeps srcpkg)        => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool)        -> GenericInstallPlan ipkg srcpkg iresult ifailure        -> Either [PlanProblem ipkg srcpkg iresult ifailure]@@ -287,7 +348,7 @@ -- ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg       => GenericInstallPlan ipkg srcpkg iresult ifailure-      -> [GenericReadyPackage srcpkg ipkg]+      -> [GenericReadyPackage srcpkg] ready plan = assert check readyPackages   where     check = if null readyPackages && null processingPackages@@ -296,22 +357,27 @@     configuredPackages = [ pkg | Configured pkg <- toList plan ]     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 :: [GenericReadyPackage srcpkg]+    readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages) +lookupReadyPackage :: forall ipkg srcpkg iresult ifailure.+                      PackageFixedDeps srcpkg+                   => GenericInstallPlan ipkg srcpkg iresult ifailure+                   -> srcpkg+                   -> Maybe (GenericReadyPackage srcpkg)+lookupReadyPackage plan pkg = do+    _ <- hasAllInstalledDeps pkg+    return (ReadyPackage pkg)+  where+     hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])     hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends -    isInstalledDep :: InstalledPackageId -> Maybe ipkg+    isInstalledDep :: UnitId -> Maybe ipkg     isInstalledDep pkgid =       -- NB: Need to check if the ID has been updated in planFakeMap, in which       -- case we might be dealing with an old pointer-      case PlanIndex.fakeLookupInstalledPackageId+      case PlanIndex.fakeLookupUnitId            (planFakeMap plan) (planIndex plan) pkgid       of         Just (PreExisting ipkg)            -> Just ipkg@@ -329,9 +395,9 @@ -- -- * The package must exist in the graph and be in the configured state. ---processing :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-               HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)-           => [GenericReadyPackage srcpkg ipkg]+processing :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+               HasUnitId srcpkg, PackageFixedDeps srcpkg)+           => [GenericReadyPackage srcpkg]            -> GenericInstallPlan ipkg srcpkg iresult ifailure            -> GenericInstallPlan ipkg srcpkg iresult ifailure processing pkgs plan = assert (invariant plan') plan'@@ -347,9 +413,9 @@ -- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. ---completed :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-              HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)-          => InstalledPackageId+completed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+              HasUnitId srcpkg, PackageFixedDeps srcpkg)+          => UnitId           -> Maybe ipkg -> iresult           -> GenericInstallPlan ipkg srcpkg iresult ifailure           -> GenericInstallPlan ipkg srcpkg iresult ifailure@@ -361,13 +427,13 @@                   planFakeMap = insert_fake_mapping mipkg                               $ planFakeMap plan,                   planIndex = PackageIndex.insert installed-                            . PackageIndex.deleteInstalledPackageId pkgid+                            . PackageIndex.deleteUnitId pkgid                             $ planIndex plan                 }     -- ...but be sure to use the *old* IPID for the lookup for the     -- preexisting record     installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult-    insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedPackageId ipkg)+    insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg)     insert_fake_mapping  _          = id  -- | Marks a package in the graph as having failed. It also marks all the@@ -376,9 +442,9 @@ -- * The package must exist in the graph and be in the processing -- state. ---failed :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-           HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)-       => InstalledPackageId -- ^ The id of the package that failed to install+failed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+           HasUnitId srcpkg, PackageFixedDeps srcpkg)+       => UnitId         -- ^ The id of the package that failed to install        -> ifailure           -- ^ The build result to use for the failed package        -> ifailure           -- ^ The build result to use for its dependencies        -> GenericInstallPlan ipkg srcpkg iresult ifailure@@ -389,7 +455,7 @@     plan'    = plan {                  planIndex = PackageIndex.merge (planIndex plan) failures                }-    ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid+    ReadyPackage srcpkg = lookupProcessingPackage plan pkgid     failures = PackageIndex.fromList              $ Failed srcpkg buildResult              : [ Failed pkg' buildResult'@@ -399,7 +465,7 @@ -- | Lookup the reachable packages in the reverse dependency graph. -- packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure-                     -> InstalledPackageId+                     -> UnitId                      -> [GenericPlanPackage ipkg srcpkg iresult ifailure] packagesThatDependOn plan pkgid = map (planPkgOf plan)                           . tail@@ -410,12 +476,12 @@ -- | Lookup a package that we expect to be in the processing state. -- lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure-                        -> InstalledPackageId-                        -> GenericReadyPackage srcpkg ipkg+                        -> UnitId+                        -> GenericReadyPackage srcpkg lookupProcessingPackage plan pkgid =   -- NB: processing packages are guaranteed to not indirect through   -- planFakeMap-  case PackageIndex.lookupInstalledPackageId (planIndex plan) pkgid of+  case PackageIndex.lookupUnitId (planIndex plan) pkgid of     Just (Processing pkg) -> pkg     _  -> internalError $ "not in processing state or no such pkg " ++                           display pkgid@@ -430,6 +496,97 @@ 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 -- ------------------------------------------------------------@@ -440,8 +597,8 @@ -- -- * if the result is @False@ use 'problems' to get a detailed list. ---valid :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-          HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+valid :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+          HasUnitId srcpkg, PackageFixedDeps srcpkg)       => FakeMap -> Bool       -> PlanIndex ipkg srcpkg iresult ifailure       -> Bool@@ -492,8 +649,8 @@ -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. ---problems :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-             HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+problems :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+             HasUnitId srcpkg, PackageFixedDeps srcpkg)          => FakeMap -> Bool          -> PlanIndex ipkg srcpkg iresult ifailure          -> [PlanProblem ipkg srcpkg iresult ifailure]@@ -502,7 +659,7 @@      [ PackageMissingDeps pkg        (catMaybes         (map-         (fmap packageId . PlanIndex.fakeLookupInstalledPackageId fakeMap index)+         (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)          missingDeps))      | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ] @@ -515,8 +672,8 @@    ++ [ PackageStateInvalid pkg pkg'      | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PlanIndex.fakeLookupInstalledPackageId fakeMap index)-                    (CD.nonSetupDeps (depends pkg))+     , Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index)+                    (CD.flatDeps (depends pkg))      , not (stateDependencyRelation pkg pkg') ]  -- | The graph of packages (nodes) and dependencies (edges) must be acyclic.@@ -524,8 +681,8 @@ -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --   which packages are involved in dependency cycles. ---acyclic :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-            HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+acyclic :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+            HasUnitId srcpkg, PackageFixedDeps srcpkg)         => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap @@ -536,7 +693,7 @@ -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --   which packages depend on packages not in the index. ---closed :: (HasInstalledPackageId ipkg, PackageFixedDeps ipkg,+closed :: (PackageFixedDeps ipkg,            PackageFixedDeps srcpkg)        => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool closed fakeMap = null . PlanIndex.brokenPackages fakeMap@@ -557,8 +714,8 @@ -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --   find out which packages are. ---consistent :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-               HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)+consistent :: (HasUnitId ipkg,   PackageFixedDeps ipkg,+               HasUnitId srcpkg, PackageFixedDeps srcpkg)            => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False @@ -594,22 +751,39 @@ stateDependencyRelation _               _                 = False  --- | Compute the dependency closure of a _source_ package in a install plan+-- | Compute the dependency closure of a package in a install plan ----- See `Distribution.Client.PlanIndex.dependencyClosure`-dependencyClosure :: (HasInstalledPackageId ipkg,   PackageFixedDeps ipkg,-                      HasInstalledPackageId srcpkg, PackageFixedDeps srcpkg)-                  => GenericInstallPlan ipkg srcpkg iresult ifailure-                  -> [PackageIdentifier]-                  -> Either [(GenericPlanPackage ipkg srcpkg iresult ifailure,-                              [InstalledPackageId])]-                            (PackageIndex-                             (GenericPlanPackage ipkg srcpkg iresult ifailure))-dependencyClosure installPlan pids =-    PlanIndex.dependencyClosure-      (planFakeMap installPlan)-      (planIndex installPlan)-      (map (resolveFakeId . fakeInstalledPackageId) pids)-  where-    resolveFakeId :: InstalledPackageId -> InstalledPackageId-    resolveFakeId ipid = Map.findWithDefault ipid ipid (planFakeMap installPlan)+dependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure+                  -> [UnitId]+                  -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+dependencyClosure plan =+    map (planPkgOf plan)+  . concatMap Tree.flatten+  . Graph.dfs (planGraph plan)+  . map (planVertexOf plan)+++reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure+                         -> [UnitId]+                         -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+reverseDependencyClosure plan =+    map (planPkgOf plan)+  . concatMap Tree.flatten+  . Graph.dfs (planGraphRev plan)+  . map (planVertexOf plan)+++topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure+                 -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+topologicalOrder plan =+    map (planPkgOf plan)+  . Graph.topSort+  $ planGraph plan+++reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure+                        -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+reverseTopologicalOrder plan =+    map (planPkgOf plan)+  . Graph.topSort+  $ planGraphRev plan
cabal/cabal-install/Distribution/Client/InstallSymlink.hs view
@@ -40,19 +40,17 @@ import Distribution.Client.Types          ( SourcePackage(..)          , GenericReadyPackage(..), ReadyPackage, enableStanzas-         , ConfiguredPackage(..) )+         , ConfiguredPackage(..) , fakeUnitId) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan)  import Distribution.Package-         ( PackageIdentifier, Package(packageId), mkPackageKey-         , packageKeyLibraryName, LibraryName )+         ( PackageIdentifier, Package(packageId), UnitId(..) ) import Distribution.Compiler          ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription-import qualified Distribution.Client.ComponentDeps as CD import Distribution.PackageDescription          ( PackageDescription ) import Distribution.PackageDescription.Configuration@@ -60,9 +58,8 @@ import Distribution.Simple.Setup          ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, CompilerInfo(..), packageKeySupported )+         ( Compiler, compilerInfo, CompilerInfo(..) ) import Distribution.System          ( Platform ) @@ -118,7 +115,7 @@ --    TODO: do we want to do this here? : --      createDirectoryIfMissing True publicBinDir       fmap catMaybes $ sequence-        [ do privateBinDir <- pkgBinDir pkg libname+        [ do privateBinDir <- pkgBinDir pkg ipid              ok <- symlinkBinary                      publicBinDir  privateBinDir                      publicExeName privateExeName@@ -126,16 +123,14 @@                then return Nothing                else return (Just (pkgid, publicExeName,                                   privateBinDir </> privateExeName))-        | (ReadyPackage (ConfiguredPackage _ _flags _ _) deps, pkg, exe) <- exes+        | (ReadyPackage _cpkg, pkg, exe) <- exes         , let pkgid  = packageId pkg-              pkg_key = mkPackageKey (packageKeySupported comp) pkgid-                                     (map Installed.libraryName-                                      (CD.nonSetupDeps deps))-              libname = packageKeyLibraryName pkgid pkg_key+              -- This is a bit dodgy; probably won't work for Backpack packages+              ipid = fakeUnitId pkgid               publicExeName  = PackageDescription.exeName exe               privateExeName = prefix ++ publicExeName ++ suffix-              prefix = substTemplate pkgid libname prefixTemplate-              suffix = substTemplate pkgid libname suffixTemplate ]+              prefix = substTemplate pkgid ipid prefixTemplate+              suffix = substTemplate pkgid ipid suffixTemplate ]   where     exes =       [ (cpkg, pkg, exe)@@ -147,8 +142,7 @@     pkgDescription :: ReadyPackage -> PackageDescription     pkgDescription (ReadyPackage (ConfiguredPackage                                     (SourcePackage _ pkg _ _)-                                    flags stanzas _)-                                  _) =+                                    flags stanzas _)) =       case finalizePackageDescription flags              (const True)              platform cinfo [] (enableStanzas stanzas pkg) of@@ -157,8 +151,8 @@      -- This is sadly rather complicated. We're kind of re-doing part of the     -- configuration for the package. :-(-    pkgBinDir :: PackageDescription -> LibraryName -> IO FilePath-    pkgBinDir pkg libname = do+    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath+    pkgBinDir pkg ipid = do       defaultDirs <- InstallDirs.defaultInstallDirs                        compilerFlavor                        (fromFlag (configUserInstall configFlags))@@ -166,14 +160,14 @@       let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)           absoluteDirs = InstallDirs.absoluteInstallDirs-                           (packageId pkg) libname+                           (packageId pkg) ipid                            cinfo InstallDirs.NoCopyDest                            platform templateDirs       canonicalizePath (InstallDirs.bindir absoluteDirs) -    substTemplate pkgid libname = InstallDirs.fromPathTemplate-                                . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid libname+    substTemplate pkgid ipid = InstallDirs.fromPathTemplate+                             . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid ipid                                                      cinfo platform      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
cabal/cabal-install/Distribution/Client/List.hs view
@@ -16,7 +16,7 @@ import Distribution.Package          ( PackageName(..), Package(..), packageName, packageVersion          , Dependency(..), simplifyDependency-         , InstalledPackageId )+         , UnitId ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed@@ -31,7 +31,7 @@ import Distribution.Simple.Program (ProgramConfiguration) import Distribution.Simple.Utils         ( equating, comparing, die, notice )-import Distribution.Simple.Setup (fromFlag, flagToMaybe)+import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex@@ -43,21 +43,21 @@          ( Text(disp), display )  import Distribution.Client.Types-         ( SourcePackage(..), Repo, SourcePackageDb(..) )+         ( SourcePackage(..), SourcePackageDb(..)+         , UnresolvedSourcePackage ) import Distribution.Client.Dependency.Types          ( PackageConstraint(..) ) import Distribution.Client.Targets          ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup-         ( GlobalFlags(..), ListFlags(..), InfoFlags(..) )+         ( GlobalFlags(..), ListFlags(..), InfoFlags(..)+         , RepoContext(..) ) import Distribution.Client.Utils          ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import Distribution.Client.FetchUtils          ( isFetched )-import Distribution.Client.HttpUtils-        ( configureTransport )  import Data.List          ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )@@ -77,21 +77,21 @@ -- | Return a list of packages matching given search strings. getPkgList :: Verbosity            -> PackageDBStack-           -> [Repo]+           -> RepoContext            -> Compiler            -> ProgramConfiguration            -> ListFlags            -> [String]            -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repos comp conf listFlags pats = do+getPkgList verbosity packageDBs repoCtxt comp conf listFlags pats = do     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb       <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb))          pkgsInfo ::-          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]         pkgsInfo             -- gather info for all packages           | null pats = mergePackages@@ -102,7 +102,7 @@           | otherwise = pkgsInfoMatching          pkgsInfoMatching ::-          [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])]+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]         pkgsInfoMatching =           let matchingInstalled = matchingPackages                                   InstalledPackageIndex.searchByNameSubstring@@ -133,7 +133,7 @@ -- | Show information about packages. list :: Verbosity      -> PackageDBStack-     -> [Repo]+     -> RepoContext      -> Compiler      -> ProgramConfiguration      -> ListFlags@@ -163,7 +163,7 @@  info :: Verbosity      -> PackageDBStack-     -> [Repo]+     -> RepoContext      -> Compiler      -> ProgramConfiguration      -> GlobalFlags@@ -173,11 +173,11 @@ info verbosity _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -info verbosity packageDBs repos comp conf+info verbosity packageDBs repoCtxt comp conf      globalFlags _listFlags userTargets = do      installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf-    sourcePkgDb   <- getSourcePackages    verbosity repos+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt     let sourcePkgIndex = packageIndex sourcePkgDb         prefs name = fromMaybe anyVersion                        (Map.lookup name (packagePreferences sourcePkgDb))@@ -190,8 +190,7 @@                       (InstalledPackageIndex.allPackages installedPkgIndex)                    ++ map packageId                       (PackageIndex.allPackages sourcePkgIndex)-    transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags))-    pkgSpecifiers <- resolveUserTargets verbosity transport+    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt                        (fromFlag $ globalWorldFile globalFlags)                        sourcePkgs' userTargets @@ -208,8 +207,8 @@   where     gatherPkgInfo :: (PackageName -> VersionRange) ->                      InstalledPackageIndex ->-                     PackageIndex.PackageIndex SourcePackage ->-                     PackageSpecifier SourcePackage ->+                     PackageIndex.PackageIndex UnresolvedSourcePackage ->+                     PackageSpecifier UnresolvedSourcePackage ->                      Either String PackageDisplayInfo     gatherPkgInfo prefs installedPkgIndex sourcePkgIndex       (NamedPackage name constraints)@@ -253,8 +252,8 @@   (PackageName -> VersionRange)   -> PackageName   -> InstalledPackageIndex-  -> PackageIndex.PackageIndex SourcePackage-  -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage])+  -> PackageIndex.PackageIndex UnresolvedSourcePackage+  -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage]) sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =   (pref, installedPkgs, sourcePkgs)   where@@ -270,7 +269,7 @@ data PackageDisplayInfo = PackageDisplayInfo {     pkgName           :: PackageName,     selectedVersion   :: Maybe Version,-    selectedSourcePkg :: Maybe SourcePackage,+    selectedSourcePkg :: Maybe UnresolvedSourcePackage,     installedVersions :: [Version],     sourceVersions    :: [Version],     preferredVersions :: VersionRange,@@ -296,7 +295,7 @@ -- | Covers source dependencies and installed dependencies in -- one type. data ExtDependency = SourceDependency Dependency-                   | InstalledDependency InstalledPackageId+                   | InstalledDependency UnitId  showPackageSummaryInfo :: PackageDisplayInfo -> String showPackageSummaryInfo pkginfo =@@ -419,8 +418,8 @@ -- mergePackageInfo :: VersionRange                  -> [Installed.InstalledPackageInfo]-                 -> [SourcePackage]-                 -> Maybe SourcePackage+                 -> [UnresolvedSourcePackage]+                 -> Maybe UnresolvedSourcePackage                  -> Bool                  -> PackageDisplayInfo mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =@@ -458,13 +457,13 @@     flags        = maybe [] Source.genPackageFlags sourceGeneric,     hasLib       = isJust installed                 || fromMaybe False-                   (fmap (isJust . Source.condLibrary) sourceGeneric),+                   (fmap (not . null . Source.condLibraries) sourceGeneric),     hasExe       = fromMaybe False                    (fmap (not . null . Source.condExecutables) sourceGeneric),     executables  = map fst (maybe [] Source.condExecutables sourceGeneric),     modules      = combine (map Installed.exposedName . Installed.exposedModules)                            installed-                           (maybe [] getListOfExposedModules . Source.library)+                           (concatMap getListOfExposedModules . Source.libraries)                            source,     dependencies =       combine (map (SourceDependency . simplifyDependency)@@ -522,10 +521,10 @@ -- both be empty. -- mergePackages :: [Installed.InstalledPackageInfo]-              -> [SourcePackage]+              -> [UnresolvedSourcePackage]               -> [( PackageName                   , [Installed.InstalledPackageInfo]-                  , [SourcePackage] )]+                  , [UnresolvedSourcePackage] )] mergePackages installedPkgs sourcePkgs =     map collect   $ mergeBy (\i a -> fst i `compare` fst a)
+ cabal/cabal-install/Distribution/Client/Manpage.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Manpage+-- Copyright   :  (c) Maciek Makowski 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for building the manual page.++module Distribution.Client.Manpage+  ( -- * Manual page generation+    manpage+  ) where++import Distribution.Simple.Command+import Distribution.Client.Setup (globalCommand)++import Data.Char (toUpper)+import Data.List (intercalate)++data FileInfo = FileInfo String String -- ^ path, description++-- | A list of files that should be documented in the manual page.+files :: [FileInfo]+files =+  [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")+  , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")+  ]++-- | Produces a manual page with @troff@ markup.+manpage :: String -> [CommandSpec a] -> String+manpage pname commands = unlines $+  [ ".TH " ++ map toUpper pname ++ " 1"+  , ".SH NAME"+  , pname ++ " \\- a system for building and packaging Haskell libraries and programs"+  , ".SH SYNOPSIS"+  , ".B " ++ pname+  , ".I command"+  , ".RI < arguments |[ options ]>..."+  , ""+  , "Where the"+  , ".I commands"+  , "are"+  , ""+  ] +++  concatMap (commandSynopsisLines pname) commands +++  [ ".SH DESCRIPTION"+  , "Cabal is the standard package system for Haskell software. It helps people to configure, "+  , "build and install Haskell software and to distribute it easily to other users and developers."+  , ""+  , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "+  , "installing existing packages and developing new packages. "+  , "It can be used to work with local packages or to install packages from online package archives, "+  , "including automatically installing dependencies. By default it is configured to use Hackage, "+  , "which is Haskell’s central package archive that contains thousands of libraries and applications "+  , "in the Cabal package format."+  , ".SH OPTIONS"+  , "Global options:"+  , ""+  ] +++  optionsLines (globalCommand []) +++  [ ".SH COMMANDS"+  ] +++  concatMap (commandDetailsLines pname) commands +++  [ ".SH FILES"+  ] +++  concatMap fileLines files +++  [ ".SH BUGS"+  , "To browse the list of known issues or report a new one please see "+  , "https://github.com/haskell/cabal/labels/cabal-install."+  ]++commandSynopsisLines :: String -> CommandSpec action -> [String]+commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ".R - " ++ commandSynopsis ui+  , ".br"+  ]+commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []++commandDetailsLines :: String -> CommandSpec action -> [String]+commandDetailsLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ""+  , commandUsage ui pname+  , ""+  ] +++  optional commandDescription +++  optional commandNotes +++  [ "Flags:"+  , ".RS"+  ] +++  optionsLines ui +++  [ ".RE"+  , ""+  ]+  where+    optional field =+      case field ui of+        Just text -> [text pname, ""]+        Nothing   -> []+commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []++optionsLines :: CommandUI flags -> [String]+optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))++data ArgumentRequired = Optional | Required+type OptionArg = (ArgumentRequired, ArgPlaceHolder)++optionLines :: OptDescr flags -> [String]+optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =+  argOptionLines description optionChars optionStrings (Required, placeHolder)+optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =+  argOptionLines description optionChars optionStrings (Optional, placeHolder)+optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =+  optionLinesIfPresent trueChars trueStrings +++  optionLinesIfPresent falseChars falseStrings +++  optionDescriptionLines description+optionLines (ChoiceOpt options) =+  concatMap choiceLines options+  where+    choiceLines (description, (optionChars, optionStrings), _, _) =+      [ optionsLine optionChars optionStrings ] +++      optionDescriptionLines description++argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]+argOptionLines description optionChars optionStrings arg =+  [ optionsLine optionChars optionStrings+  , optionArgLine arg+  ] +++  optionDescriptionLines description++optionLinesIfPresent :: [Char] -> [String] -> [String]+optionLinesIfPresent optionChars optionStrings =+  if null optionChars && null optionStrings then []+  else                                           [ optionsLine optionChars optionStrings, ".br" ]++optionDescriptionLines :: String -> [String]+optionDescriptionLines description =+  [ ".RS"+  , description+  , ".RE"+  , ""+  ]++optionsLine :: [Char] -> [String] -> String+optionsLine optionChars optionStrings =+  intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)++shortOptions :: [Char] -> [String]+shortOptions = map (\c -> "\\-" ++ [c])++longOptions :: [String] -> [String]+longOptions = map (\s -> "\\-\\-" ++ s)++optionArgLine :: OptionArg -> String+optionArgLine (Required, placeHolder) = ".I " ++ placeHolder+optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"++fileLines :: FileInfo -> [String]+fileLines (FileInfo path description) =+  [ path+  , ".RS"+  , description+  , ".RE"+  , ""+  ]
+ cabal/cabal-install/Distribution/Client/PackageHash.hs view
@@ -0,0 +1,226 @@+{-# 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,+       pkgHashStripExes           :: Bool,+       pkgHashDebugInfo           :: DebugInfoLevel,+       pkgHashExtraLibDirs        :: [FilePath],+       pkgHashExtraFrameworkDirs  :: [FilePath],+       pkgHashExtraIncludeDirs    :: [FilePath],+       pkgHashProgPrefix          :: Maybe PathTemplate,+       pkgHashProgSuffix          :: Maybe PathTemplate++--     TODO: [required eventually] pkgHashToolsVersions     ?+--     TODO: [required eventually] pkgHashToolsExtraOptions ?+--     TODO: [research required] and what about docs?+     }+  deriving Show+++-- | Calculate the overall hash to be used for an 'InstalledPackageId'.+--+hashPackageHashInputs :: PackageHashInputs -> HashValue+hashPackageHashInputs = hashValue . renderPackageHashInputs++-- | Render a textual representation of the 'PackageHashInputs'.+--+-- The 'hashValue' of this text is the overall package hash.+--+renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString+renderPackageHashInputs PackageHashInputs{+                          pkgHashPkgId,+                          pkgHashSourceHash,+                          pkgHashDirectDeps,+                          pkgHashOtherConfig =+                            PackageHashConfigInputs{..}+                        } =+    -- The purpose of this somewhat laboured rendering (e.g. why not just+    -- use show?) is so that existing package hashes do not change+    -- unnecessarily when new configuration inputs are added into the hash.++    -- In particular, the assumption is that when a new configuration input+    -- is included into the hash, that existing packages will typically get+    -- the default value for that feature. So if we avoid adding entries with+    -- the default value then most of the time adding new features will not+    -- change the hashes of existing packages and so fewer packages will need+    -- to be rebuilt. ++    --TODO: [nice to have] ultimately we probably want to put this config info+    -- into the ghc-pkg db. At that point this should probably be changed to+    -- use the config file infrastructure so it can be read back in again.+    LBS.pack $ unlines $ catMaybes+      [ entry "pkgid"       display pkgHashPkgId+      , entry "src"         showHashValue pkgHashSourceHash+      , entry "deps"        (intercalate ", " . map display+                                              . Set.toList) pkgHashDirectDeps+        -- and then all the config+      , entry "compilerid"  display pkgHashCompilerId+      , entry "platform"    display pkgHashPlatform+      , opt   "flags" []    showFlagAssignment pkgHashFlagAssignment+      , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs+      , opt   "vanilla-lib" True  display pkgHashVanillaLib+      , opt   "shared-lib"  False display pkgHashSharedLib+      , opt   "dynamic-exe" False display pkgHashDynExe+      , opt   "ghci-lib"    False display pkgHashGHCiLib+      , opt   "prof-lib"    False display pkgHashProfLib+      , opt   "prof-exe"    False display pkgHashProfExe+      , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail +      , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail +      , opt   "hpc"          False display pkgHashCoverage+      , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization+      , opt   "split-objs"   False display pkgHashSplitObjs+      , opt   "stripped-lib" False display pkgHashStripLibs+      , opt   "stripped-exe" True  display pkgHashStripExes+      , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo+      , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs+      , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs+      , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs+      , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix+      , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix+      ]+  where+    entry key     format value = Just (key ++ ": " ++ format value)+    opt   key def format value+         | value == def = Nothing+         | otherwise    = entry key format value++    showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst)+      where+        showEntry (FlagName name, False) = '-' : name+        showEntry (FlagName name, True)  = '+' : name++-----------------------------------------------+-- The specific choice of hash implementation+--++-- Is a crypto hash necessary here? One thing to consider is who controls the+-- inputs and what's the result of a hash collision. Obviously we should not+-- install packages we don't trust because they can run all sorts of code, but+-- if I've checked there's no TH, no custom Setup etc, is there still a+-- problem? If someone provided us a tarball that hashed to the same value as+-- some other package and we installed it, we could end up re-using that+-- installed package in place of another one we wanted. So yes, in general+-- there is some value in preventing intentional hash collisions in installed+-- package ids.++newtype HashValue = HashValue (Hash.Digest Hash.SHA256)+  deriving (Eq, Show)++instance Binary HashValue where+  put (HashValue digest) = put (Hash.toBytes digest)+  get = do+    bs <- get+    case Hash.digestFromByteString bs of+      Nothing     -> fail "HashValue: bad digest"+      Just digest -> return (HashValue digest)++hashValue :: LBS.ByteString -> HashValue+hashValue = HashValue . Hash.hashlazy++showHashValue :: HashValue -> String+showHashValue (HashValue digest) = BS.unpack (Hash.digestToHexByteString digest)++readFileHashValue :: FilePath -> IO HashValue+readFileHashValue tarball =+    withBinaryFile tarball ReadMode $ \hnd ->+      evaluate . hashValue =<< LBS.hGetContents hnd+
cabal/cabal-install/Distribution/Client/PackageIndex.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.PackageIndex@@ -54,6 +55,9 @@ import Data.Monoid (Monoid(..)) #endif import Data.Maybe (isJust, fromMaybe)+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Semigroup (Semigroup((<>)))  import Distribution.Package          ( PackageName(..), PackageIdentifier(..)@@ -78,14 +82,20 @@   --   (Map PackageName [pkg]) -  deriving (Show, Read, Functor)+  deriving (Eq, Show, Read, Functor, Generic)+--FIXME: the Functor instance here relies on no package id changes +instance Package pkg => Semigroup (PackageIndex pkg) where+  (<>) = merge+ instance Package pkg => Monoid (PackageIndex pkg) where   mempty  = PackageIndex Map.empty-  mappend = merge+  mappend = (<>)   --save one mappend with empty in the common case:   mconcat [] = mempty   mconcat xs = foldr1 mappend xs++instance Binary pkg => Binary (PackageIndex pkg)  invariant :: Package pkg => PackageIndex pkg -> Bool invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
cabal/cabal-install/Distribution/Client/PackageUtils.hs view
@@ -15,11 +15,11 @@   ) where  import Distribution.Package-         ( packageVersion, packageName, Dependency(..) )+         ( packageVersion, packageName, Dependency(..), PackageName(..) ) import Distribution.PackageDescription-         ( PackageDescription(..) )+         ( PackageDescription(..), libName ) import Distribution.Version-         ( withinRange )+         ( withinRange, isAnyVersion )  -- | The list of dependencies that refer to external packages -- rather than internal package components.@@ -30,5 +30,7 @@     -- True if this dependency is an internal one (depends on a library     -- defined in the same package).     internal (Dependency depName versionRange) =-            depName == packageName pkg &&-            packageVersion pkg `withinRange` versionRange+           (depName == packageName pkg &&+            packageVersion pkg `withinRange` versionRange) ||+           (unPackageName depName `elem` map libName (libraries pkg) &&+            isAnyVersion versionRange)
cabal/cabal-install/Distribution/Client/ParseUtils.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.ParseUtils@@ -7,13 +9,41 @@ -- Parsing utilities. ----------------------------------------------------------------------------- -module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )+module Distribution.Client.ParseUtils (++    -- * Fields and field utilities+    FieldDescr(..),+    liftField,+    liftFields,+    filterFields,+    mapFieldNames,+    commandOptionToField,+    commandOptionsToFields,++    -- * Sections and utilities+    SectionDescr(..),+    liftSection,++    -- * Parsing and printing flat config+    parseFields,+    ppFields,+    ppSection,++    -- * Parsing and printing config with sections and subsections+    parseFieldsAndSections,+    ppFieldsAndSections,++    -- ** Top level of config files+    parseConfig,+    showConfig,+  )        where  import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), warning, lineNo )-import qualified Distribution.ParseUtils as ParseUtils-         ( Field(..) )+         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo+         , Field(..), liftField, readFieldsFlat )+import Distribution.Simple.Command+         ( OptionField, viewAsFieldDescr )  import Control.Monad    ( foldM ) import Text.PrettyPrint ( (<>), (<+>), ($+$) )@@ -21,18 +51,101 @@ import qualified Text.PrettyPrint as Disp          ( Doc, text, colon, vcat, empty, isEmpty, nest ) ---FIXME: replace this with something better-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a-parseFields fields = foldM setField++-------------------------+-- FieldDescr utilities+--++liftFields :: (b -> a)+           -> (a -> b -> b)+           -> [FieldDescr a]+           -> [FieldDescr b]+liftFields get set = map (liftField get set)+++-- | Given a collection of field descriptions, keep only a given list of them,+-- identified by name.+--+filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]+filterFields includeFields = filter ((`elem` includeFields) . fieldName)++-- | Apply a name mangling function to the field names of all the field+-- descriptions. The typical use case is to apply some prefix.+--+mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]+mapFieldNames mangleName =+    map (\descr -> descr { fieldName = mangleName (fieldName descr) })+++-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.+--+commandOptionToField :: OptionField a -> FieldDescr a+commandOptionToField = viewAsFieldDescr++-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.+--+commandOptionsToFields :: [OptionField a] -> [FieldDescr a]+commandOptionsToFields = map viewAsFieldDescr+++------------------------------------------+-- SectionDescr definition and utilities+--++-- | The description of a section in a config file. It can contains both+-- fields and optionally further subsections. See also 'FieldDescr'.+--+data SectionDescr a = forall b. SectionDescr {+       sectionName        :: String,+       sectionFields      :: [FieldDescr b],+       sectionSubsections :: [SectionDescr b],+       sectionGet         :: a -> [(String, b)],+       sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,+       sectionEmpty       :: b+     }++-- | To help construction of config file descriptions in a modular way it is+-- useful to define fields and sections on local types and then hoist them+-- into the parent types when combining them in bigger descriptions.+--+-- This is essentially a lens operation for 'SectionDescr' to help embedding+-- one inside another.+--+liftSection :: (b -> a)+            -> (a -> b -> b)+            -> SectionDescr a+            -> SectionDescr b+liftSection get' set' (SectionDescr name fields sections get set empty) =+    let sectionGet' = get . get'+        sectionSet' lineno param x y = do+          x' <- set lineno param x (get' y)+          return (set' x' y)+     in SectionDescr name fields sections sectionGet' sectionSet' empty+++-------------------------------------+-- Parsing and printing flat config+--++-- | Parse a bunch of semi-parsed 'Field's according to a set of field+-- descriptions. It accumulates the result on top of a given initial value.+--+-- This only covers the case of flat configuration without subsections. See+-- also 'parseFieldsAndSections'.+--+parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a+parseFields fieldDescrs =+    foldM setField   where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (ParseUtils.F line name value) =+    fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]++    setField accum (F line name value) =       case Map.lookup name fieldMap of         Just (FieldDescr _ _ set) -> set line value accum         Nothing -> do           warning $ "Unrecognized field " ++ name ++ " on line " ++ show line           return accum+     setField accum f = do       warning $ "Unrecognized stanza on line " ++ show (lineNo f)       return accum@@ -41,8 +154,9 @@ -- that also optionally print default values for empty fields as comments. -- ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-ppFields fields def cur = Disp.vcat [ ppField name (fmap getter def) (getter cur)-                                    | FieldDescr name getter _ <- fields]+ppFields fields def cur =+    Disp.vcat [ ppField name (fmap getter def) (getter cur)+              | FieldDescr name getter _ <- fields]  ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc ppField name mdef cur@@ -51,6 +165,11 @@                                 <> Disp.colon <+> def) mdef   | otherwise        = Disp.text name <> Disp.colon <+> cur +-- | Pretty print a section.+--+-- Since 'ppFields' does not cover subsections you can use this to add them.+-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.+-- ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc ppSection name arg fields def cur   | Disp.isEmpty fieldsDoc = Disp.empty@@ -60,3 +179,101 @@     fieldsDoc = ppFields fields def cur     argDoc | arg == "" = Disp.empty            | otherwise = Disp.text arg+++-----------------------------------------+-- Parsing and printing non-flat config+--++-- | Much like 'parseFields' but it also allows subsections. The permitted+-- subsections are given by a list of 'SectionDescr's.+--+parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a+                       -> [Field] -> ParseResult a+parseFieldsAndSections fieldDescrs sectionDescrs =+    foldM setField+  where+    fieldMap   = Map.fromList [ (fieldName   f, f) | f <- fieldDescrs   ]+    sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]++    setField a (F line name value) =+      case Map.lookup name fieldMap of+        Just (FieldDescr _ _ set) -> set line value a+        Nothing -> do+          warning $ "Unrecognized field '" ++ name+                 ++ "' on line " ++ show line+          return a++    setField a (Section line name param fields) =+      case Map.lookup name sectionMap of+        Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do+          b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields+          set line param b a+        Nothing -> do+          warning $ "Unrecognized section '" ++ name+                 ++ "' on line " ++ show line+          return a++    setField accum (block@IfBlock {}) = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo block)+      return accum++-- | Much like 'ppFields' but also pretty prints any subsections. Subsection+-- are only shown if they are non-empty.+--+-- Note that unlike 'ppFields', at present it does not support printing+-- default values. If needed, adding such support would be quite reasonable.+--+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+ppFieldsAndSections fieldDescrs sectionDescrs val =+    ppFields fieldDescrs Nothing val+      $+$+    Disp.vcat+      [ Disp.text "" $+$ sectionDoc+      | SectionDescr {+          sectionName, sectionGet,+          sectionFields, sectionSubsections+        } <- sectionDescrs+      , (param, x) <- sectionGet val+      , let sectionDoc = ppSectionAndSubsections+                           sectionName param+                           sectionFields sectionSubsections x+      , not (Disp.isEmpty sectionDoc)+      ]++-- | Unlike 'ppSection' which has to be called directly, this gets used via+-- 'ppFieldsAndSections' and so does not need to be exported.+--+ppSectionAndSubsections :: String -> String+                        -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+ppSectionAndSubsections name arg fields sections cur+  | Disp.isEmpty fieldsDoc = Disp.empty+  | otherwise              = Disp.text name <+> argDoc+                             $+$ (Disp.nest 2 fieldsDoc)+  where+    fieldsDoc = showConfig fields sections cur+    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg+++-----------------------------------------------+-- Top level config file parsing and printing+--++-- | Parse a string in the config file syntax into a value, based on a+-- description of the configuration file in terms of its fields and sections.+--+-- It accumulates the result on top of a given initial (typically empty) value.+--+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a+            -> String -> ParseResult a+parseConfig fieldDescrs sectionDescrs empty str =+      parseFieldsAndSections fieldDescrs sectionDescrs empty+  =<< readFieldsFlat str++-- | Render a value in the config file syntax, based on a description of the+-- configuration file in terms of its fields and sections.+--+showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+showConfig = ppFieldsAndSections+
+ cabal/cabal-install/Distribution/Client/PkgConfigDb.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.PkgConfigDb+-- Copyright   :  (c) Iñaki García Etxebarria 2016+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Read the list of packages available to pkg-config.+-----------------------------------------------------------------------------+module Distribution.Client.PkgConfigDb+    (+     PkgConfigDb+    , readPkgConfigDb+    , pkgConfigDbFromList+    , pkgConfigPkgIsPresent+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif++import Control.Exception (IOException, handle)+import Data.Char (isSpace)+import qualified Data.Map as M+import Data.Version (parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)++import Distribution.Package+    ( PackageName(..) )+import Distribution.Verbosity+    ( Verbosity )+import Distribution.Version+    ( Version, VersionRange, withinRange )++import Distribution.Simple.Program+    ( ProgramConfiguration, pkgConfigProgram, getProgramOutput,+      requireProgram )+import Distribution.Simple.Utils+    ( info )++-- | The list of packages installed in the system visible to+-- @pkg-config@. This is an opaque datatype, to be constructed with+-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.+data PkgConfigDb =  PkgConfigDb (M.Map PackageName (Maybe Version))+                 -- ^ If an entry is `Nothing`, this means that the+                 -- package seems to be present, but we don't know the+                 -- exact version (because parsing of the version+                 -- number failed).+                 | NoPkgConfigDb+                 -- ^ For when we could not run pkg-config successfully.+     deriving (Show)++-- | Query pkg-config for the list of installed packages, together+-- with their versions. Return a `PkgConfigDb` encapsulating this+-- information.+readPkgConfigDb :: Verbosity -> ProgramConfiguration -> IO PkgConfigDb+readPkgConfigDb verbosity conf = handle ioErrorHandler $ do+  (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram conf+  pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]+  -- The output of @pkg-config --list-all@ also includes a description+  -- for each package, which we do not need.+  let pkgNames = map (takeWhile (not . isSpace)) pkgList+  pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig+                             ("--modversion" : pkgNames)+  (return . pkgConfigDbFromList . zip pkgNames) pkgVersions+      where+        -- For when pkg-config invocation fails (possibly because of a+        -- too long command line).+        ioErrorHandler :: IOException -> IO PkgConfigDb+        ioErrorHandler e = do+          info verbosity ("Failed to query pkg-config, Cabal will continue"+                          ++ " without solving for pkg-config constraints: "+                          ++ show e)+          return NoPkgConfigDb++-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.+pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb+pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs+    where+      convert :: (String, String) -> (PackageName, Maybe Version)+      convert (n,vs) = (PackageName n,+                        case (reverse . readP_to_S parseVersion) vs of+                          (v, "") : _ -> Just v+                          _           -> Nothing -- Version not (fully)+                                                 -- understood.+                       )++-- | Check whether a given package range is satisfiable in the given+-- @pkg-config@ database.+pkgConfigPkgIsPresent :: PkgConfigDb -> PackageName -> VersionRange -> Bool+pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =+    case M.lookup pn db of+      Nothing       -> False    -- Package not present in the DB.+      Just Nothing  -> True     -- Package present, but version unknown.+      Just (Just v) -> withinRange v vr+-- If we could not read the pkg-config database successfully we allow+-- the check to succeed. The plan found by the solver may fail to be+-- executed later on, but we have no grounds for rejecting the plan at+-- this stage.+pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True
cabal/cabal-install/Distribution/Client/PlanIndex.hs view
@@ -8,25 +8,20 @@     -- * FakeMap and related operations     FakeMap   , fakeDepends-  , fakeLookupInstalledPackageId+  , fakeLookupUnitId     -- * Graph traversal functions   , brokenPackages-  , dependencyClosure   , dependencyCycles   , dependencyGraph   , dependencyInconsistencies-  , reverseDependencyClosure-  , reverseTopologicalOrder-  , topologicalOrder   ) where  import Prelude hiding (lookup) import qualified Data.Map as Map-import qualified Data.Tree  as Tree import qualified Data.Graph as Graph import Data.Array ((!)) import Data.Map (Map)-import Data.Maybe (isNothing, fromMaybe, fromJust)+import Data.Maybe (isNothing) import Data.Either (rights)  #if !MIN_VERSION_base(4,8,0)@@ -34,7 +29,7 @@ #endif  import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), InstalledPackageId(..)+         ( PackageName(..), PackageIdentifier(..), UnitId(..)          , Package(..), packageName, packageVersion          ) import Distribution.Version@@ -45,59 +40,54 @@ import Distribution.Client.Types          ( PackageFixedDeps(..) ) import Distribution.Simple.PackageIndex-         ( PackageIndex, allPackages, insert, lookupInstalledPackageId )+         ( PackageIndex, allPackages, insert, lookupUnitId ) import Distribution.Package-         ( HasInstalledPackageId(..), PackageId )+         ( HasUnitId(..), PackageId )  -- Note [FakeMap] -------------------- We'd like to use the PackageIndex defined in this module for--- cabal-install's InstallPlan.  However, at the moment, this--- data structure is indexed by InstalledPackageId, which we don't--- know until after we've compiled a package (whereas InstallPlan--- needs to store not-compiled packages in the index.) Eventually,--- an InstalledPackageId will be calculatable prior to actually--- building the package (making it something of a misnomer), but--- at the moment, the "fake installed package ID map" is a workaround--- to solve this problem while reusing PackageIndex.  The basic idea--- is that, since we don't know what an InstalledPackageId is--- beforehand, we just fake up one based on the package ID (it only--- needs to be unique for the particular install plan), and fill--- it out with the actual generated InstalledPackageId after the--- package is successfully compiled.+-- We'd like to use the PackageIndex defined in this module for cabal-install's+-- InstallPlan.  However, at the moment, this data structure is indexed by+-- UnitId, which we don't know until after we've compiled a package+-- (whereas InstallPlan needs to store not-compiled packages in the index.)+-- Eventually, an UnitId will be calculatable prior to actually building+-- the package, but at the moment, the "fake installed package ID map" is a+-- workaround to solve this problem while reusing PackageIndex.  The basic idea+-- is that, since we don't know what an UnitId is beforehand, we just fake+-- up one based on the package ID (it only needs to be unique for the particular+-- install plan), and fill it out with the actual generated UnitId after+-- the package is successfully compiled. ----- However, there is a problem: in the index there may be--- references using the old package ID, which are now dangling if--- we update the InstalledPackageId.  We could map over the entire--- index to update these pointers as well (a costly operation), but--- instead, we've chosen to parametrize a variety of important functions--- by a FakeMap, which records what a fake installed package ID was--- actually resolved to post-compilation.  If we do a lookup, we first--- check and see if it's a fake ID in the FakeMap.+-- However, there is a problem: in the index there may be references using the+-- old package ID, which are now dangling if we update the UnitId.  We+-- could map over the entire index to update these pointers as well (a costly+-- operation), but instead, we've chosen to parametrize a variety of important+-- functions by a FakeMap, which records what a fake installed package ID was+-- actually resolved to post-compilation.  If we do a lookup, we first check and+-- see if it's a fake ID in the FakeMap. ----- It's a bit grungy, but we expect this to only be temporary anyway.--- (Another possible workaround would have been to *not* update--- the installed package ID, but I decided this would be hard to--- understand.)+-- It's a bit grungy, but we expect this to only be temporary anyway.  (Another+-- possible workaround would have been to *not* update the installed package ID,+-- but I decided this would be hard to understand.) --- | Map from fake installed package IDs to real ones.  See Note [FakeMap]-type FakeMap = Map InstalledPackageId InstalledPackageId+-- | Map from fake package keys to real ones.  See Note [FakeMap]+type FakeMap = Map UnitId UnitId  -- | Variant of `depends` which accepts a `FakeMap` -- -- Analogous to `fakeInstalledDepends`. See Note [FakeMap].-fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [InstalledPackageId]+fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId] fakeDepends fakeMap = fmap (map resolveFakeId) . depends   where-    resolveFakeId :: InstalledPackageId -> InstalledPackageId+    resolveFakeId :: UnitId -> UnitId     resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap ---- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'.  See Note+--- | Variant of 'lookupUnitId' which accepts a 'FakeMap'.  See Note --- [FakeMap].-fakeLookupInstalledPackageId :: FakeMap -> PackageIndex a -> InstalledPackageId+fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId                              -> Maybe a-fakeLookupInstalledPackageId fakeMap index pkg =-  lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap)+fakeLookupUnitId fakeMap index pkg =+  lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)  -- | All packages that have dependencies that are not in the index. --@@ -106,13 +96,13 @@ brokenPackages :: (PackageFixedDeps pkg)                => FakeMap                -> PackageIndex pkg-               -> [(pkg, [InstalledPackageId])]+               -> [(pkg, [UnitId])] brokenPackages fakeMap index =   [ (pkg, missing)   | pkg  <- allPackages index   , let missing =-          [ pkg' | pkg' <- CD.nonSetupDeps (depends pkg)-                 , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]+          [ pkg' | pkg' <- CD.flatDeps (depends pkg)+                 , isNothing (fakeLookupUnitId fakeMap index pkg') ]   , not (null missing) ]  -- | Compute all roots of the install plan, and verify that the transitive@@ -122,7 +112,7 @@ -- may be absent from the subplans even if the larger plan contains a dependency -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here.-dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasInstalledPackageId pkg)+dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)                           => FakeMap                           -> Bool                           -> PackageIndex pkg@@ -141,8 +131,8 @@ -- This is the set of all top-level library roots (taken together normally, or -- as singletons sets if we are considering them as independent goals), along -- with all setup dependencies of all packages.-rootSets :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)-         => FakeMap -> Bool -> PackageIndex pkg -> [[InstalledPackageId]]+rootSets :: (PackageFixedDeps pkg, HasUnitId pkg)+         => FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]] rootSets fakeMap indepGoals index =        if indepGoals then map (:[]) libRoots else [libRoots]     ++ setupRoots index@@ -153,10 +143,10 @@ -- -- The library roots are the set of packages with no reverse dependencies -- (no reverse library dependencies but also no reverse setup dependencies).-libraryRoots :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)-             => FakeMap -> PackageIndex pkg -> [InstalledPackageId]+libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg)+             => FakeMap -> PackageIndex pkg -> [UnitId] libraryRoots fakeMap index =-    map (installedPackageId . toPkgId) roots+    map toPkgId roots   where     (graph, toPkgId, _) = dependencyGraph fakeMap index     indegree = Graph.indegree graph@@ -164,7 +154,7 @@     isRoot v = indegree ! v == 0  -- | The setup dependencies of each package in the plan-setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[InstalledPackageId]]+setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]] setupRoots = filter (not . null)            . map (CD.setupDeps . depends)            . allPackages@@ -180,7 +170,7 @@ -- distinct. -- dependencyInconsistencies' :: forall pkg.-                              (PackageFixedDeps pkg, HasInstalledPackageId pkg)+                              (PackageFixedDeps pkg, HasUnitId pkg)                            => FakeMap                            -> PackageIndex pkg                            -> [(PackageName, [(PackageIdentifier, Version)])]@@ -195,7 +185,7 @@     --   and each installed ID of that that package     --     the associated package instance     --     and a list of reverse dependencies (as source IDs)-    inverseIndex :: Map PackageName (Map InstalledPackageId (pkg, [PackageId]))+    inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))     inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))       [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])       | -- For each package @pkg@@@ -203,7 +193,7 @@         -- Find out which @ipid@ @pkg@ depends on       , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)         -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)-      , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid]+      , Just dep <- [fakeLookupUnitId fakeMap index ipid]       ]      -- If, in a single install plan, we depend on more than one version of a@@ -215,15 +205,14 @@     reallyIsInconsistent []       = False     reallyIsInconsistent [_p]     = False     reallyIsInconsistent [p1, p2] =-      let pid1 = installedPackageId p1-          pid2 = installedPackageId p2+      let pid1 = installedUnitId p1+          pid2 = installedUnitId p2       in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)       && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)     reallyIsInconsistent _ = True   - -- | Find if there are any cycles in the dependency graph. If there are no -- cycles the result is @[]@. --@@ -231,14 +220,15 @@ -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. ---dependencyCycles :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)                  => FakeMap                  -> PackageIndex pkg                  -> [[pkg]] dependencyCycles fakeMap index =   [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]   where-    adjacencyList = [ (pkg, installedPackageId pkg, CD.nonSetupDeps (fakeDepends fakeMap pkg))+    adjacencyList = [ (pkg, installedUnitId pkg,+                            CD.flatDeps (fakeDepends fakeMap pkg))                     | pkg <- allPackages index ]  @@ -249,11 +239,11 @@ -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageIdentifier's do not occur in the index.-dependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)                   => FakeMap                   -> PackageIndex pkg-                  -> [InstalledPackageId]-                  -> Either [(pkg, [InstalledPackageId])]+                  -> [UnitId]+                  -> Either [(pkg, [UnitId])]                             (PackageIndex pkg) dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of   (completed, []) -> Right completed@@ -261,79 +251,39 @@  where     closure completed failed []             = (completed, failed)     closure completed failed (pkgid:pkgids) =-      case fakeLookupInstalledPackageId fakeMap index pkgid of+      case fakeLookupUnitId fakeMap index pkgid of         Nothing   -> closure completed (pkgid:failed) pkgids         Just pkg  ->-          case fakeLookupInstalledPackageId fakeMap completed-               (installedPackageId pkg) of+          case fakeLookupUnitId fakeMap completed+               (installedUnitId pkg) of             Just _  -> closure completed  failed pkgids             Nothing -> closure completed' failed pkgids'               where completed' = insert pkg completed                     pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids  -topologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)-                 => FakeMap -> PackageIndex pkg -> [pkg]-topologicalOrder fakeMap index = map toPkgId-                               . Graph.topSort-                               $ graph-  where (graph, toPkgId, _) = dependencyGraph fakeMap index---reverseTopologicalOrder :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)-                        => FakeMap -> PackageIndex pkg -> [pkg]-reverseTopologicalOrder fakeMap index = map toPkgId-                                      . Graph.topSort-                                      . Graph.transposeG-                                      $ graph-  where (graph, toPkgId, _) = dependencyGraph fakeMap index----- | Takes the transitive closure of the packages reverse dependencies.------ * The given 'PackageIdentifier's must be in the index.----reverseDependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)-                         => FakeMap-                         -> PackageIndex pkg-                         -> [InstalledPackageId]-                         -> [pkg]-reverseDependencyClosure fakeMap index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)--  where-    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph fakeMap index-    reverseDepGraph = Graph.transposeG depGraph-    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"--- -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. ---dependencyGraph :: (PackageFixedDeps pkg, HasInstalledPackageId pkg)+dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)                 => FakeMap                 -> PackageIndex pkg                 -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    InstalledPackageId -> Maybe Graph.Vertex)+                    Graph.Vertex -> UnitId,+                    UnitId -> Maybe Graph.Vertex) dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)   where     (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges-    vertexToPkg = fromJust-                . (\((), key, _targets) -> lookupInstalledPackageId index key)-                . vertexToPkg'+    vertexToPkg v = case vertexToPkg' v of+                      ((), pkgid, _targets) -> pkgid      pkgs  = allPackages index     edges = map edgesFrom pkgs      resolve   pid = Map.findWithDefault pid pid fakeMap     edgesFrom pkg = ( ()-                    , resolve (installedPackageId pkg)-                    , CD.nonSetupDeps (fakeDepends fakeMap pkg)+                    , resolve (installedUnitId pkg)+                    , CD.flatDeps (fakeDepends fakeMap pkg)                     )
+ cabal/cabal-install/Distribution/Client/ProjectBuilding.hs view
@@ -0,0 +1,1284 @@+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns,+             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,+             ScopedTypeVariables #-}++-- | +--+module Distribution.Client.ProjectBuilding (+    BuildStatus(..),+    BuildStatusMap,+    BuildStatusRebuild(..),+    BuildReason(..),+    MonitorChangedReason(..),+    rebuildTargetsDryRun,+    rebuildTargets+  ) where++import           Distribution.Client.PackageHash (renderPackageHashInputs)+import           Distribution.Client.RebuildMonad+import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanning++import           Distribution.Client.Types+                   ( PackageLocation(..), GenericReadyPackage(..)+                   , PackageFixedDeps(..)+                   , InstalledPackageId, installedPackageId )+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, GenericPlanPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.ComponentDeps as CD+import           Distribution.Client.ComponentDeps (ComponentDeps)+import           Distribution.Client.DistDirLayout+import           Distribution.Client.FileMonitor+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+import           Distribution.Client.GlobalFlags (RepoContext)+import qualified Distribution.Client.Tar as Tar+import           Distribution.Client.Setup (filterConfigureFlags)+import           Distribution.Client.Utils (removeExistingFile)++import           Distribution.Package hiding (InstalledPackageId, installedPackageId)+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as Installed+import           Distribution.Simple.Program+import qualified Distribution.Simple.Setup as Cabal+import           Distribution.Simple.Command (CommandUI)+import qualified Distribution.Simple.Register as Cabal+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Simple.LocalBuildInfo (ComponentName)+import qualified Distribution.Simple.Program.HcPkg as HcPkg++import           Distribution.Simple.Utils hiding (matchFileGlob)+import           Distribution.Version+import           Distribution.Verbosity+import           Distribution.Text+import           Distribution.ParseUtils ( showPWarning )++import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy as LBS++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+import           Control.Monad+import           Control.Exception+import           Control.Concurrent.Async+import           Control.Concurrent.MVar+import           Data.List+import           Data.Maybe++import           System.FilePath+import           System.IO+import           System.Directory+import           System.Exit (ExitCode)+++------------------------------------------------------------------------------+-- * Overall building strategy.+------------------------------------------------------------------------------+--+-- We start with an 'ElaboratedInstallPlan' that has already been improved by+-- reusing packages from the store. So the remaining packages in the+-- 'InstallPlan.Configured' state are ones we either need to build or rebuild.+--+-- First, we do a preliminary dry run phase where we work out which packages+-- we really need to (re)build, and for the ones we do need to build which+-- build phase to start at.+++------------------------------------------------------------------------------+-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?+------------------------------------------------------------------------------++-- We split things like this for a couple reasons. Firstly we need to be able+-- to do dry runs, and these need to be reasonably accurate in terms of+-- letting users know what (and why) things are going to be (re)built.+--+-- Given that we need to be able to do dry runs, it would not be great if+-- we had to repeat all the same work when we do it for real. Not only is+-- it duplicate work, but it's duplicate code which is likely to get out of+-- sync. So we do things only once. We preserve info we discover in the dry+-- run phase and rely on it later when we build things for real. This also+-- somewhat simplifies the build phase. So this way the dry run can't so+-- easily drift out of sync with the real thing since we're relying on the+-- info it produces.+--+-- An additional advantage is that it makes it easier to debug rebuild+-- errors (ie rebuilding too much or too little), since all the rebuild+-- decisions are made without making any state changes at the same time+-- (that would make it harder to reproduce the problem sitation).+++-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'+--+type BuildStatusMap = Map InstalledPackageId BuildStatus++-- | The build status for an individual package. That is, the state that the+-- package is in prior to initiating a (re)build.+--+-- It serves two purposes:+--+--  * For dry-run output, it lets us explain to the user if and why a package+--    is going to be (re)built.+--+--  * It tell us what step to start or resume building from, and carries+--    enough information for us to be able to do so.+--+data BuildStatus =++     -- | The package is in the 'InstallPlan.PreExisting' state, so does not+     --   need building.+     BuildStatusPreExisting++     -- | The package has not been downloaded yet, so it will have to be+     --   downloaded, unpacked and built.+   | BuildStatusDownload++     -- | The package has not been unpacked yet, so it will have to be+     --   unpacked and built.+   | BuildStatusUnpack FilePath++     -- | The package exists in a local dir already, and just needs building+     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style+     --   packages.+   | BuildStatusRebuild FilePath BuildStatusRebuild++     -- | The package exists in a local dir already, and is fully up to date.+     --   So this package can be put into the 'InstallPlan.Installed' state+     --   and it does not need to be built.+   | BuildStatusUpToDate (Maybe InstalledPackageInfo) BuildSuccess++-- | For a package that is going to be built or rebuilt, the state it's in now.+--+-- So again, this tells us why a package needs to be rebuilt and what build+-- phases need to be run. The 'MonitorChangedReason' gives us details like+-- which file changed, which is mainly for high verbosity debug output.+--+data BuildStatusRebuild =++     -- | The package configuration changed, so the configure and build phases+     --   needs to be (re)run.+     BuildStatusConfigure (MonitorChangedReason ())++     -- | The configuration has not changed but the build phase needs to be+     -- rerun. We record the reason the (re)build is needed.+     --+     -- The optional registration info here tells us if we've registered the+     -- package already, or if we stil need to do that after building.+     --+   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason++data BuildReason =+     -- | The depencencies of this package have been (re)built so the build+     -- phase needs to be rerun.+     --+     -- The optional registration info here tells us if we've registered the+     -- package already, or if we stil need to do that after building.+     --+     BuildReasonDepsRebuilt++     -- | Changes in files within the package (or first run or corrupt cache) +   | BuildReasonFilesChanged (MonitorChangedReason ())++     -- | An important special case is that no files have changed but the+     -- set of components the /user asked to build/ has changed. We track the+     -- set of components /we have built/, which of course only grows (until+     -- some other change resets it).+     --+     -- The @Set 'ComponentName'@ is the set of components we have built+     -- previously. When we update the monitor we take the union of the ones+     -- we have built previously with the ones the user has asked for this+     -- time and save those. See 'updatePackageBuildFileMonitor'.+     --+   | BuildReasonExtraTargets (Set ComponentName)++     -- | Although we're not going to build any additional targets as a whole,+     -- we're going to build some part of a component or run a repl or any+     -- other action that does not result in additional persistent artifacts.+     -- +   | BuildReasonEphemeralTargets++-- | Which 'BuildStatus' values indicate we'll have to do some build work of+-- some sort. In particular we use this as part of checking if any of a+-- package's deps have changed.+--+buildStatusRequiresBuild :: BuildStatus -> Bool+buildStatusRequiresBuild BuildStatusPreExisting = False+buildStatusRequiresBuild BuildStatusUpToDate {} = False+buildStatusRequiresBuild _                      = True++-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.+--+-- It gives us the 'BuildStatusMap' and also gives us an improved version of+-- the 'ElaboratedInstallPlan' with packages switched to the+-- 'InstallPlan.Installed' state when we find that they're already up to date.+--+rebuildTargetsDryRun :: DistDirLayout+                     -> ElaboratedInstallPlan+                     -> IO (ElaboratedInstallPlan, BuildStatusMap)+rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do++    -- Do the various checks to work out the 'BuildStatus' of each package+    pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg++    -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as+    -- 'InstallPlan.Installed'.+    let installPlan' = improveInstallPlanWithUpToDatePackages+                         installPlan pkgsBuildStatus++    return (installPlan', pkgsBuildStatus)+  where+    dryRunPkg :: ElaboratedPlanPackage+              -> ComponentDeps [BuildStatus]+              -> IO BuildStatus+    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =+      return BuildStatusPreExisting++    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do+      mloc <- checkFetched (pkgSourceLocation pkg)+      case mloc of+        Nothing -> return BuildStatusDownload++        Just (LocalUnpackedPackage srcdir) ->+          -- For the case of a user-managed local dir, irrespective of the+          -- build style, we build from that directory and put build+          -- artifacts under the shared dist directory.+          dryRunLocalPkg pkg depsBuildStatus srcdir++        -- The three tarball cases are handled the same as each other,+        -- though depending on the build style.+        Just (LocalTarballPackage    tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++        Just (RemoteTarballPackage _ tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++        Just (RepoTarballPackage _ _ tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++    dryRunPkg (InstallPlan.Processing {}) _ = unexpectedState+    dryRunPkg (InstallPlan.Installed  {}) _ = unexpectedState+    dryRunPkg (InstallPlan.Failed     {}) _ = unexpectedState++    unexpectedState = error "rebuildTargetsDryRun: unexpected package state"++    dryRunTarballPkg :: ElaboratedConfiguredPackage+                     -> ComponentDeps [BuildStatus]+                     -> FilePath+                     -> IO BuildStatus+    dryRunTarballPkg pkg depsBuildStatus tarball =+      case pkgBuildStyle pkg of+        BuildAndInstall  -> return (BuildStatusUnpack tarball)+        BuildInplaceOnly -> do+          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test+          exists <- doesDirectoryExist srcdir+          if exists+            then dryRunLocalPkg pkg depsBuildStatus srcdir+            else return (BuildStatusUnpack tarball)+      where+        srcdir = distUnpackedSrcDirectory (packageId pkg)++    dryRunLocalPkg :: ElaboratedConfiguredPackage+                   -> ComponentDeps [BuildStatus]+                   -> FilePath+                   -> IO BuildStatus+    dryRunLocalPkg pkg depsBuildStatus srcdir = do+        -- Go and do lots of I/O, reading caches and probing files to work out+        -- if anything has changed+        change <- checkPackageFileMonitorChanged+                    packageFileMonitor pkg srcdir depsBuildStatus+        case change of+          -- It did change, giving us 'BuildStatusRebuild' info on why+          Left rebuild ->+            return (BuildStatusRebuild srcdir rebuild)++          -- No changes, the package is up to date. Use the saved build results.+          Right (mipkg, buildSuccess) ->+            return (BuildStatusUpToDate mipkg buildSuccess)+      where+        packageFileMonitor =+          newPackageFileMonitor distDirLayout (packageId pkg)+++-- | A specialised traversal over the packages in an install plan.+--+-- The packages are visited in dependency order, starting with packages with no+-- depencencies. The result for each package is accumulated into a 'Map' and+-- returned as the final result. In addition, when visting a package, the+-- visiting function is passed the results for all the immediate package+-- depencencies. This can be used to propagate information from depencencies.+--+foldMInstallPlanDepOrder+  :: forall m ipkg srcpkg iresult ifailure b.+     (Monad m,+      HasUnitId ipkg,   PackageFixedDeps ipkg,+      HasUnitId srcpkg, PackageFixedDeps srcpkg)+  => GenericInstallPlan ipkg srcpkg iresult ifailure+  -> (GenericPlanPackage ipkg srcpkg iresult ifailure ->+      ComponentDeps [b] -> m b)+  -> m (Map InstalledPackageId b)+foldMInstallPlanDepOrder plan0 visit =+    go Map.empty (InstallPlan.reverseTopologicalOrder plan0)+  where+    go :: Map InstalledPackageId b+       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]+       -> m (Map InstalledPackageId b)+    go !results [] = return results++    go !results (pkg : pkgs) = do+      -- we go in the right order so the results map has entries for all deps+      let depresults :: ComponentDeps [b]+          depresults =+            fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results+                                   in result))+                 (depends pkg)+      result <- visit pkg depresults+      let results' = Map.insert (installedPackageId pkg) result results+      go results' pkgs++improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan+                                       -> BuildStatusMap+                                       -> ElaboratedInstallPlan+improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =+    replaceWithPreInstalled installPlan+      [ (installedPackageId pkg, mipkg, buildSuccess)+      | InstallPlan.Configured pkg+          <- InstallPlan.reverseTopologicalOrder installPlan+      , let ipkgid = installedPackageId pkg+            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus+      , BuildStatusUpToDate mipkg buildSuccess <- [pkgBuildStatus]+      ]+  where+    replaceWithPreInstalled =+      foldl' (\plan (ipkgid, mipkg, buildSuccess) ->+                InstallPlan.preinstalled ipkgid mipkg buildSuccess plan)+++-----------------------------+-- Package change detection+--++-- | As part of the dry run for local unpacked packages we have to check if the+-- package config or files have changed. That is the purpose of+-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.+--+-- When a package is (re)built, the monitor must be updated to reflect the new+-- state of the package. Because we sometimes build without reconfiguring the+-- state updates are split into two, one for package config changes and one+-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'+-- and 'updatePackageBuildFileMonitor'.+--+data PackageFileMonitor = PackageFileMonitor {+       pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),+       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildSuccess,+       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)+     }++newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor+newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =+    PackageFileMonitor {+      pkgFileMonitorConfig =+        newFileMonitor (distPackageCacheFile pkgid "config"),++      pkgFileMonitorBuild =+        FileMonitor {+          fileMonitorCacheFile = distPackageCacheFile pkgid "build",+          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->+            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,+          fileMonitorCheckIfOnlyValueChanged = True+        },++      pkgFileMonitorReg =+        newFileMonitor (distPackageCacheFile pkgid "registration")+    }++-- | Helper function for 'checkPackageFileMonitorChanged',+-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.+--+-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by+-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.+--+packageFileMonitorKeyValues :: ElaboratedConfiguredPackage+                            -> (ElaboratedConfiguredPackage, Set ComponentName)+packageFileMonitorKeyValues pkg =+    (pkgconfig, buildComponents)+  where+    -- The first part is the value used to guard (re)configuring the package.+    -- That is, if this value changes then we will reconfigure.+    -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of+    -- information that affects the (re)configure step. But those parts that+    -- do not affect the configure step need to be nulled out. Those parts are+    -- the specific targets that we're going to build.+    --+    pkgconfig = pkg {+      pkgBuildTargets  = [],+      pkgReplTarget    = Nothing,+      pkgBuildHaddocks = False+    }++    -- The second part is the value used to guard the build step. So this is+    -- more or less the opposite of the first part, as it's just the info about+    -- what targets we're going to build.+    --+    buildComponents = pkgBuildTargetWholeComponents pkg++-- | Do all the checks on whether a package has changed and thus needs either+-- rebuilding or reconfiguring and rebuilding.+--+checkPackageFileMonitorChanged :: PackageFileMonitor+                               -> ElaboratedConfiguredPackage+                               -> FilePath+                               -> ComponentDeps [BuildStatus]+                               -> IO (Either BuildStatusRebuild+                                            (Maybe InstalledPackageInfo,+                                             BuildSuccess))+checkPackageFileMonitorChanged PackageFileMonitor{..}+                               pkg srcdir depsBuildStatus = do+    --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged+    configChanged <- checkFileMonitorChanged+                       pkgFileMonitorConfig srcdir pkgconfig+    case configChanged of+      MonitorChanged monitorReason ->+          return (Left (BuildStatusConfigure monitorReason'))+        where+          monitorReason' = fmap (const ()) monitorReason++      MonitorUnchanged () _+          -- The configChanged here includes the identity of the dependencies,+          -- so depsBuildStatus is just needed for the changes in the content+          -- of depencencies.+        | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do+            regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()+            let mreg = changedToMaybe regChanged+            return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))++        | otherwise -> do+            buildChanged  <- checkFileMonitorChanged+                               pkgFileMonitorBuild srcdir buildComponents+            regChanged    <- checkFileMonitorChanged+                               pkgFileMonitorReg srcdir ()+            let mreg = changedToMaybe regChanged+            case (buildChanged, regChanged) of+              (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason = BuildReasonExtraTargets prevBuildComponents++              (MonitorChanged monitorReason, _) ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason    = BuildReasonFilesChanged monitorReason'+                  monitorReason' = fmap (const ()) monitorReason++              (MonitorUnchanged _ _, MonitorChanged monitorReason) ->+                -- this should only happen if the file is corrupt or been+                -- manually deleted. We don't want to bother with another+                -- phase just for this, so we'll reregister by doing a build.+                  return (Left (BuildStatusBuild Nothing buildReason))+                where+                  buildReason    = BuildReasonFilesChanged monitorReason'+                  monitorReason' = fmap (const ()) monitorReason++              (MonitorUnchanged _ _, MonitorUnchanged _ _)+                | pkgHasEphemeralBuildTargets pkg ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason = BuildReasonEphemeralTargets++              (MonitorUnchanged buildSuccess _, MonitorUnchanged mipkg _) ->+                return (Right (mipkg, buildSuccess))+  where+    (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg+    changedToMaybe (MonitorChanged     _) = Nothing+    changedToMaybe (MonitorUnchanged x _) = Just x+++updatePackageConfigFileMonitor :: PackageFileMonitor+                               -> FilePath+                               -> ElaboratedConfiguredPackage+                               -> IO ()+updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}+                               srcdir pkg =+    updateFileMonitor pkgFileMonitorConfig srcdir Nothing+                      [] pkgconfig ()+  where+    (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg++updatePackageBuildFileMonitor :: PackageFileMonitor+                              -> FilePath+                              -> MonitorTimestamp+                              -> ElaboratedConfiguredPackage+                              -> BuildStatusRebuild+                              -> [FilePath]+                              -> BuildSuccess+                              -> IO ()+updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}+                              srcdir timestamp pkg pkgBuildStatus+                              allSrcFiles buildSuccess =+    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)+                      (map monitorFileHashed allSrcFiles)+                      buildComponents' buildSuccess+  where+    (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg++    -- If the only thing that's changed is that we're now building extra+    -- components, then we can avoid later unnecessary rebuilds by saving the+    -- total set of components that have been built, namely the union of the+    -- existing ones plus the new ones. If files also changed this would be+    -- the wrong thing to do. Note that we rely on the+    -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee+    -- that it's /only/ the value that changed not any files that changed.+    buildComponents' =+      case pkgBuildStatus of+        BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)+          -> buildComponents `Set.union` prevBuildComponents+        _ -> buildComponents++updatePackageRegFileMonitor :: PackageFileMonitor+                            -> FilePath+                            -> Maybe InstalledPackageInfo+                            -> IO ()+updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}+                            srcdir mipkg =+    updateFileMonitor pkgFileMonitorReg srcdir Nothing+                      [] () mipkg++invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()+invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =+    removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)+++------------------------------------------------------------------------------+-- * Doing it: executing an 'ElaboratedInstallPlan'+------------------------------------------------------------------------------+++-- | Build things for real.+--+-- It requires the 'BuildStatusMap' gatthered by 'rebuildTargetsDryRun'.+--+rebuildTargets :: Verbosity+               -> DistDirLayout+               -> ElaboratedInstallPlan+               -> ElaboratedSharedConfig+               -> BuildStatusMap+               -> BuildTimeSettings+               -> IO ElaboratedInstallPlan+rebuildTargets verbosity+               distDirLayout@DistDirLayout{..}+               installPlan+               sharedPackageConfig+               pkgsBuildStatus+               buildSettings@BuildTimeSettings{buildSettingNumJobs} = do++    -- Concurrency control: create the job controller and concurrency limits+    -- for downloading, building and installing.+    jobControl    <- if isParallelBuild then newParallelJobControl+                                        else newSerialJobControl+    buildLimit    <- newJobLimit buildSettingNumJobs+    installLock   <- newLock -- serialise installation+    cacheLock     <- newLock -- serialise access to setup exe cache+                             --TODO: [code cleanup] eliminate setup exe cache++    createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory+    createDirectoryIfMissingVerbose verbosity False distTempDirectory++    -- Before traversing the install plan, pre-emptively find all packages that+    -- will need to be downloaded and start downloading them.+    asyncDownloadPackages verbosity withRepoCtx+                          installPlan pkgsBuildStatus $ \downloadMap ->++      -- For each package in the plan, in dependency order, but in parallel...+      executeInstallPlan verbosity jobControl installPlan $ \pkg ->+        handle (return . BuildFailure) $ --TODO: review exception handling++        let ipkgid = installedPackageId pkg+            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in++        rebuildTarget+          verbosity+          distDirLayout+          buildSettings downloadMap+          buildLimit installLock cacheLock +          sharedPackageConfig+          pkg+          pkgBuildStatus+  where+    isParallelBuild = buildSettingNumJobs >= 2+    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity +                        buildSettings++-- | Given all the context and resources, (re)build an individual package.+--+rebuildTarget :: Verbosity+              -> DistDirLayout+              -> BuildTimeSettings+              -> AsyncDownloadMap+              -> JobLimit -> Lock -> Lock+              -> ElaboratedSharedConfig+              -> ElaboratedReadyPackage+              -> BuildStatus+              -> IO BuildResult+rebuildTarget verbosity+              distDirLayout@DistDirLayout{distBuildDirectory}+              buildSettings downloadMap+              buildLimit installLock cacheLock+              sharedPackageConfig+              rpkg@(ReadyPackage pkg)+              pkgBuildStatus =++    -- We rely on the 'BuildStatus' to decide which phase to start from:+    case pkgBuildStatus of+      BuildStatusDownload              -> downloadPhase+      BuildStatusUnpack tarball        -> unpackTarballPhase tarball+      BuildStatusRebuild srcdir status -> rebuildPhase status srcdir++      -- TODO: perhaps re-nest the types to make these impossible+      BuildStatusPreExisting {} -> unexpectedState+      BuildStatusUpToDate    {} -> unexpectedState+  where+    unexpectedState = error "rebuildTarget: unexpected package status"++    downloadPhase = do+        downsrcloc <- waitAsyncPackageDownload verbosity downloadMap pkg+        case downsrcloc of+          DownloadedTarball tarball -> unpackTarballPhase tarball+          --TODO: [nice to have] git/darcs repos etc+++    unpackTarballPhase tarball =+      withJobLimit buildLimit $+        withTarballLocalDirectory+          verbosity distDirLayout tarball+          (packageId pkg) (pkgBuildStyle pkg)+          (pkgDescriptionOverride pkg) $++          case pkgBuildStyle pkg of+            BuildAndInstall  -> buildAndInstall+            BuildInplaceOnly -> buildInplace buildStatus+              where+                buildStatus = BuildStatusConfigure MonitorFirstRun++    -- Note that this really is rebuild, not build. It can only happen for+    -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages+    -- would only start from download or unpack phases.+    --+    rebuildPhase buildStatus srcdir =+        assert (pkgBuildStyle pkg == BuildInplaceOnly) $++        withJobLimit buildLimit $+          buildInplace buildStatus srcdir builddir+      where+        builddir = distBuildDirectory (packageId pkg)++    buildAndInstall srcdir builddir =+        buildAndInstallUnpackedPackage+          verbosity distDirLayout+          buildSettings installLock cacheLock+          sharedPackageConfig+          rpkg+          srcdir builddir'+      where+        builddir' = makeRelative srcdir builddir+        --TODO: [nice to have] ^^ do this relative stuff better++    buildInplace buildStatus srcdir builddir =+        --TODO: [nice to have] use a relative build dir rather than absolute+        buildInplaceUnpackedPackage+          verbosity distDirLayout+          buildSettings cacheLock+          sharedPackageConfig+          rpkg+          buildStatus+          srcdir builddir++--TODO: [nice to have] do we need to use a with-style for the temp files for downloading http+-- packages, or are we going to cache them persistently?++type AsyncDownloadMap = Map (PackageLocation (Maybe FilePath))+                            (MVar DownloadedSourceLocation)++data DownloadedSourceLocation = DownloadedTarball FilePath+                              --TODO: [nice to have] git/darcs repos etc++downloadedSourceLocation :: PackageLocation FilePath+                         -> Maybe DownloadedSourceLocation+downloadedSourceLocation pkgloc =+    case pkgloc of+      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)+      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)+      _                              -> Nothing++-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the+-- packages we have to download and fork off an async action to download them.+-- We download them in dependency order so that the one's we'll need+-- first are the ones we will start downloading first.+--+-- The body action is passed a map from those packages (identified by their+-- location) to a completion var for that package. So the body action should+-- lookup the location and use 'waitAsyncPackageDownload' to get the result.+--+asyncDownloadPackages :: Verbosity+                      -> ((RepoContext -> IO ()) -> IO ())+                      -> ElaboratedInstallPlan+                      -> BuildStatusMap+                      -> (AsyncDownloadMap -> IO a)+                      -> IO a+asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body+  | null pkgsToDownload = body Map.empty+  | otherwise = do+    --TODO: [research required] use parallel downloads? if so, use the fetchLimit++    asyncDownloadVars <- mapM (\loc -> (,) loc <$> newEmptyMVar) pkgsToDownload++    let downloadAction :: IO ()+        downloadAction =+          withRepoCtx $ \repoctx ->+            forM_ asyncDownloadVars $ \(pkgloc, var) -> do+              Just scrloc <- downloadedSourceLocation <$>+                             fetchPackage verbosity repoctx pkgloc+              putMVar var scrloc++    withAsync downloadAction $ \_ ->+      body (Map.fromList asyncDownloadVars)+  where+    pkgsToDownload = +      [ pkgSourceLocation pkg+      | InstallPlan.Configured pkg+         <- InstallPlan.reverseTopologicalOrder installPlan+      , let ipkgid = installedPackageId pkg+            Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus+      , BuildStatusDownload <- [pkgBuildStatus]+      ]+++-- | Check if a package needs downloading, and if so expect to find a download+-- in progress in the given 'AsyncDownloadMap' and wait on it to finish.+--+waitAsyncPackageDownload :: Verbosity+                         -> AsyncDownloadMap+                         -> ElaboratedConfiguredPackage+                         -> IO DownloadedSourceLocation+waitAsyncPackageDownload verbosity downloadMap pkg =+    case Map.lookup (pkgSourceLocation pkg) downloadMap of+      Just hnd -> do+        debug verbosity $+          "Waiting for download of " ++ display (packageId pkg) ++ " to finish"+        --TODO: [required eventually] do the exception handling on download stuff+        takeMVar hnd+      Nothing ->+        fail "waitAsyncPackageDownload: package not being download"+++executeInstallPlan+  :: forall ipkg srcpkg iresult.+     (HasUnitId ipkg,   PackageFixedDeps ipkg,+      HasUnitId srcpkg, PackageFixedDeps srcpkg)+  => Verbosity+  -> JobControl IO ( GenericReadyPackage srcpkg+                   , GenericBuildResult ipkg iresult BuildFailure )+  -> GenericInstallPlan ipkg srcpkg iresult BuildFailure+  -> (    GenericReadyPackage srcpkg+       -> IO (GenericBuildResult ipkg iresult BuildFailure))+  -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure)+executeInstallPlan verbosity jobCtl plan0 installPkg =+    tryNewTasks 0 plan0+  where+    tryNewTasks taskCount plan = do+      case InstallPlan.ready plan of+        [] | taskCount == 0 -> return plan+           | otherwise      -> waitForTasks taskCount plan+        pkgs                -> do+          sequence_+            [ do debug verbosity $ "Ready to install " ++ display pkgid+                 spawnJob jobCtl $ do+                   buildResult <- installPkg pkg+                   return (pkg, buildResult)+            | pkg <- pkgs+            , let pkgid = packageId pkg+            ]++          let taskCount' = taskCount + length pkgs+              plan'      = InstallPlan.processing pkgs plan+          waitForTasks taskCount' plan'++    waitForTasks taskCount plan = do+      debug verbosity $ "Waiting for install task to finish..."+      (pkg, buildResult) <- collectJob jobCtl+      let taskCount' = taskCount-1+          plan'      = updatePlan pkg buildResult plan+      tryNewTasks taskCount' plan'++    updatePlan :: GenericReadyPackage srcpkg+               -> GenericBuildResult ipkg iresult BuildFailure+               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure+               -> GenericInstallPlan ipkg srcpkg iresult BuildFailure+    updatePlan pkg (BuildSuccess mipkg buildSuccess) =+        InstallPlan.completed (installedPackageId pkg) mipkg buildSuccess++    updatePlan pkg (BuildFailure buildFailure) =+        InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure+      where+        depsFailure = DependentFailed (packageId pkg)+        -- So this first pkgid failed for whatever reason (buildFailure).+        -- All the other packages that depended on this pkgid, which we+        -- now cannot build, we mark as failing due to 'DependentFailed'+        -- which kind of means it was not their fault.+++-- | Ensure that the package is unpacked in an appropriate directory, either+-- a temporary one or a persistent one under the shared dist directory. +--+withTarballLocalDirectory+  :: Verbosity+  -> DistDirLayout+  -> FilePath+  -> PackageId+  -> BuildStyle+  -> Maybe CabalFileText+  -> (FilePath -> FilePath -> IO a)+  -> IO a+withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}+                          tarball pkgid buildstyle pkgTextOverride+                          buildPkg  =+      case buildstyle of+        -- In this case we make a temp dir, unpack the tarball to there and+        -- build and install it from that temp dir.+        BuildAndInstall ->+          withTempDirectory verbosity distTempDirectory+                            (display (packageName pkgid)) $ \tmpdir -> do+            unpackPackageTarball verbosity tarball tmpdir+                                 pkgid pkgTextOverride+            let srcdir   = tmpdir </> display pkgid+                builddir = srcdir </> "dist"+            buildPkg srcdir builddir++        -- In this case we make sure the tarball has been unpacked to the+        -- appropriate location under the shared dist dir, and then build it+        -- inplace there+        BuildInplaceOnly -> do+          let srcrootdir = distUnpackedSrcRootDirectory+              srcdir     = distUnpackedSrcDirectory pkgid+              builddir   = distBuildDirectory pkgid+          -- TODO: [nice to have] use a proper file monitor rather than this dir exists test+          exists <- doesDirectoryExist srcdir+          unless exists $ do+            createDirectoryIfMissingVerbose verbosity False srcrootdir+            unpackPackageTarball verbosity tarball srcrootdir+                                 pkgid pkgTextOverride+            moveTarballShippedDistDirectory verbosity distDirLayout+                                            srcrootdir pkgid+          buildPkg srcdir builddir+++unpackPackageTarball :: Verbosity -> FilePath -> FilePath+                     -> PackageId -> Maybe CabalFileText+                     -> IO ()+unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =+    --TODO: [nice to have] switch to tar package and catch tar exceptions+    annotateFailure UnpackFailed $ do++      -- Unpack the tarball+      --+      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."+      Tar.extractTarGzFile parentdir pkgsubdir tarball++      -- Sanity check+      --+      exists <- doesFileExist cabalFile+      when (not exists) $+        die $ "Package .cabal file not found in the tarball: " ++ cabalFile++      -- Overwrite the .cabal with the one from the index, when appropriate+      --+      case pkgTextOverride of+        Nothing     -> return ()+        Just pkgtxt -> do+          info verbosity $ "Updating " ++ display pkgname <.> "cabal"+                        ++ " with the latest revision from the index."+          writeFileAtomic cabalFile pkgtxt++  where+    cabalFile = parentdir </> pkgsubdir+                          </> display pkgname <.> "cabal"+    pkgsubdir = display pkgid+    pkgname   = packageName pkgid+++-- | This is a bit of a hacky workaround. A number of packages ship+-- pre-processed .hs files in a dist directory inside the tarball. We don't+-- use the standard 'dist' location so unless we move this dist dir to the+-- right place then we'll miss the shipped pre-procssed files. This hacky+-- approach to shipped pre-procssed files ought to be replaced by a proper+-- system, though we'll still need to keep this hack for older packages.+--+moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout+                                -> FilePath -> PackageId -> IO ()+moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}+                                parentdir pkgid = do+    distDirExists <- doesDirectoryExist tarballDistDir+    when distDirExists $ do+      debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"+                                   ++ targetDistDir ++ "'"+      --TODO: [nice to have] or perhaps better to copy, and use a file monitor+      renameDirectory tarballDistDir targetDistDir+  where+    tarballDistDir = parentdir </> display pkgid </> "dist"+    targetDistDir  = distBuildDirectory pkgid+++buildAndInstallUnpackedPackage :: Verbosity+                               -> DistDirLayout+                               -> BuildTimeSettings -> Lock -> Lock+                               -> ElaboratedSharedConfig+                               -> ElaboratedReadyPackage+                               -> FilePath -> FilePath+                               -> IO BuildResult+buildAndInstallUnpackedPackage verbosity+                               DistDirLayout{distTempDirectory}+                               BuildTimeSettings {+                                 buildSettingNumJobs,+                                 buildSettingLogFile+                               }+                               installLock cacheLock+                               pkgshared@ElaboratedSharedConfig {+                                 pkgConfigCompiler  = compiler,+                                 pkgConfigPlatform  = platform,+                                 pkgConfigProgramDb = progdb+                               }+                               rpkg@(ReadyPackage pkg)+                               srcdir builddir = do++    createDirectoryIfMissingVerbose verbosity False builddir+    initLogFile++    --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like+    --      we do for ghc, with a proper options type and rendering step+    --      which will also let us call directly into the lib, rather than always+    --      going via the lib's command line interface, which would also allow+    --      passing data like installed packages, compiler, and program db for a+    --      quicker configure.++    --TODO: [required feature] docs and tests+    --TODO: [required feature] sudo re-exec++    -- Configure phase+    when isParallelBuild $+      notice verbosity $ "Configuring " ++ display pkgid ++ "..."+    annotateFailure ConfigureFailed $+      setup configureCommand configureFlags++    -- Build phase+    when isParallelBuild $+      notice verbosity $ "Building " ++ display pkgid ++ "..."+    annotateFailure BuildFailed $+      setup buildCommand buildFlags++    -- Install phase+    mipkg <-+      criticalSection installLock $ +      annotateFailure InstallFailed $ do+      --TODO: [research required] do we need the installLock for copying? can we not do that in+      -- parallel? Isn't it just registering that we have to lock for?++      --TODO: [required eventually] need to lock installing this ipkig so other processes don't+      -- stomp on our files, since we don't have ABI compat, not safe to replace++      -- TODO: [required eventually] note that for nix-style installations it is not necessary to do+      -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a+      -- shared bin dir.++      -- Actual installation+      setup Cabal.copyCommand copyFlags+      +      LBS.writeFile+        (InstallDirs.prefix (pkgInstallDirs pkg) </> "cabal-hash.txt") $+        (renderPackageHashInputs (packageHashInputs pkgshared pkg))++      -- here's where we could keep track of the installed files ourselves if+      -- we wanted by calling copy to an image dir and then we would make a+      -- manifest and move it to its final location++      --TODO: [nice to have] we should actually have it make an image in store/incomming and+      -- then when it's done, move it to its final location, to reduce problems+      -- with installs failing half-way. Could also register and then move.++      -- For libraries, grab the package configuration file+      -- and register it ourselves+      if pkgRequiresRegistration pkg+        then do+          ipkg <- generateInstalledPackageInfo+          -- We register ourselves rather than via Setup.hs. We need to+          -- grab and modify the InstalledPackageInfo. We decide what+          -- the installed package id is, not the build system.+          let ipkg' = ipkg { Installed.installedUnitId = ipkgid }+          Cabal.registerPackage verbosity compiler progdb+                                HcPkg.MultiInstance+                                (pkgRegisterPackageDBStack pkg) ipkg'+          return (Just ipkg')+        else return Nothing++    --TODO: [required feature] docs and test phases+    let docsResult  = DocsNotTried+        testsResult = TestsNotTried++    return (BuildSuccess mipkg (BuildOk docsResult testsResult))++  where+    pkgid  = packageId rpkg+    ipkgid = installedPackageId rpkg++    isParallelBuild = buildSettingNumJobs >= 2++    configureCommand = Cabal.configureCommand defaultProgramConfiguration+    configureFlags v = flip filterConfigureFlags v $+                       setupHsConfigureFlags rpkg pkgshared+                                             verbosity builddir++    buildCommand     = Cabal.buildCommand defaultProgramConfiguration+    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir++    generateInstalledPackageInfo :: IO InstalledPackageInfo+    generateInstalledPackageInfo =+      withTempInstalledPackageInfoFile+        verbosity distTempDirectory $ \pkgConfFile -> do+        -- make absolute since setup changes dir+        pkgConfFile' <- canonicalizePath pkgConfFile+        let registerFlags _ = setupHsRegisterFlags+                                pkg pkgshared+                                verbosity builddir+                                pkgConfFile'+        setup Cabal.registerCommand registerFlags++    copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir++    scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir+                                         isParallelBuild cacheLock++    setup :: CommandUI flags -> (Version -> flags) -> IO ()+    setup cmd flags =+      withLogging $ \mLogFileHandle -> +        setupWrapper+          verbosity+          scriptOptions { useLoggingHandle = mLogFileHandle }+          (Just (pkgDescription pkg))+          cmd flags []++    mlogFile =+      case buildSettingLogFile of+        Nothing        -> Nothing+        Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid)++    initLogFile =+      case mlogFile of+        Nothing      -> return ()+        Just logFile -> do+          createDirectoryIfMissing True (takeDirectory logFile)+          exists <- doesFileExist logFile+          when exists $ removeFile logFile++    withLogging action =+      case mlogFile of+        Nothing      -> action Nothing+        Just logFile -> withFile logFile AppendMode (action . Just)+++buildInplaceUnpackedPackage :: Verbosity+                            -> DistDirLayout+                            -> BuildTimeSettings -> Lock+                            -> ElaboratedSharedConfig+                            -> ElaboratedReadyPackage+                            -> BuildStatusRebuild+                            -> FilePath -> FilePath+                            -> IO BuildResult+buildInplaceUnpackedPackage verbosity+                            distDirLayout@DistDirLayout {+                              distTempDirectory,+                              distPackageCacheDirectory+                            }+                            BuildTimeSettings{buildSettingNumJobs}+                            cacheLock+                            pkgshared@ElaboratedSharedConfig {+                              pkgConfigCompiler  = compiler,+                              pkgConfigProgramDb = progdb+                            }+                            rpkg@(ReadyPackage pkg)+                            buildStatus+                            srcdir builddir = do++        --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here+        --      builddir is not enough, we also need the per-package cachedir+        createDirectoryIfMissingVerbose verbosity False builddir+        createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid)+        createPackageDBIfMissing verbosity compiler progdb (pkgBuildPackageDBStack pkg)++        -- Configure phase+        --+        whenReConfigure $ do+          setup configureCommand configureFlags []+          invalidatePackageRegFileMonitor packageFileMonitor+          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg++        -- Build phase+        --+        let docsResult  = DocsNotTried+            testsResult = TestsNotTried++            buildSuccess :: BuildSuccess+            buildSuccess = BuildOk docsResult testsResult++        whenRebuild $ do+          timestamp <- beginUpdateFileMonitor+          setup buildCommand buildFlags buildArgs++          --TODO: [required eventually] temporary hack. We need to look at the package description+          -- and work out the exact file monitors to use+          allSrcFiles <- filter (not . ("dist-newstyle" `isPrefixOf`))+                     <$> getDirectoryContentsRecursive srcdir++          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp+                                        pkg buildStatus+                                        allSrcFiles buildSuccess++        mipkg <- whenReRegister $ do+          -- Register locally+          mipkg <- if pkgRequiresRegistration pkg+            then do+                ipkg <- generateInstalledPackageInfo+                -- We register ourselves rather than via Setup.hs. We need to+                -- grab and modify the InstalledPackageInfo. We decide what+                -- the installed package id is, not the build system.+                let ipkg' = ipkg { Installed.installedUnitId = ipkgid }+                Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance+                                      (pkgRegisterPackageDBStack pkg)+                                      ipkg'+                return (Just ipkg')++           else return Nothing++          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg+          return mipkg++        -- Repl phase+        --+        whenRepl $+          setup replCommand replFlags replArgs++        -- Haddock phase+        whenHaddock $+          setup haddockCommand haddockFlags []++        return (BuildSuccess mipkg buildSuccess)++  where+    pkgid  = packageId rpkg+    ipkgid = installedPackageId rpkg++    isParallelBuild = buildSettingNumJobs >= 2++    packageFileMonitor = newPackageFileMonitor distDirLayout pkgid++    whenReConfigure action = case buildStatus of+      BuildStatusConfigure _ -> action+      _                      -> return ()++    whenRebuild action+      | null (pkgBuildTargets pkg) = return ()+      | otherwise                  = action++    whenRepl action+      | isNothing (pkgReplTarget pkg) = return ()+      | otherwise                     = action++    whenHaddock action+      | pkgBuildHaddocks pkg = action+      | otherwise            = return ()++    whenReRegister  action = case buildStatus of+      BuildStatusConfigure          _ -> action+      BuildStatusBuild Nothing      _ -> action+      BuildStatusBuild (Just mipkg) _ -> return mipkg++    configureCommand = Cabal.configureCommand defaultProgramConfiguration+    configureFlags v = flip filterConfigureFlags v $+                       setupHsConfigureFlags rpkg pkgshared+                                             verbosity builddir++    buildCommand     = Cabal.buildCommand defaultProgramConfiguration+    buildFlags   _   = setupHsBuildFlags pkg pkgshared+                                         verbosity builddir+    buildArgs        = setupHsBuildArgs  pkg++    replCommand      = Cabal.replCommand defaultProgramConfiguration+    replFlags _      = setupHsReplFlags pkg pkgshared+                                        verbosity builddir+    replArgs         = setupHsReplArgs  pkg++    haddockCommand   = Cabal.haddockCommand+    haddockFlags _   = setupHsHaddockFlags pkg pkgshared+                                           verbosity builddir++    scriptOptions    = setupHsScriptOptions rpkg pkgshared+                                            srcdir builddir+                                            isParallelBuild cacheLock++    setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO ()+    setup cmd flags args =+      setupWrapper verbosity+                   scriptOptions+                   (Just (pkgDescription pkg))+                   cmd flags args++    generateInstalledPackageInfo :: IO InstalledPackageInfo+    generateInstalledPackageInfo =+      withTempInstalledPackageInfoFile+        verbosity distTempDirectory $ \pkgConfFile -> do+        -- make absolute since setup changes dir+        pkgConfFile' <- canonicalizePath pkgConfFile+        let registerFlags _ = setupHsRegisterFlags+                                pkg pkgshared+                                verbosity builddir+                                pkgConfFile'+        setup Cabal.registerCommand registerFlags []+++-- helper+annotateFailure :: (String -> BuildFailure) -> IO a -> IO a+annotateFailure annotate action =+  action `catches`+    [ Handler $ \ioe  -> handler (ioe  :: IOException)+    , Handler $ \exit -> handler (exit :: ExitCode)+    ]+  where+    handler :: Exception e => e -> IO a+    handler = throwIO . annotate . show+                       --TODO: [nice to have] use displayException when available+++withTempInstalledPackageInfoFile :: Verbosity -> FilePath+                                 -> (FilePath -> IO ())+                                 -> IO InstalledPackageInfo+withTempInstalledPackageInfoFile verbosity tempdir action =+    withTempFile tempdir "package-registration-" $ \pkgConfFile hnd -> do+      hClose hnd+      action pkgConfFile++      (warns, ipkg) <- withUTF8FileContents pkgConfFile $ \pkgConfStr ->+        case Installed.parseInstalledPackageInfo pkgConfStr of+          Installed.ParseFailed perror -> pkgConfParseFailed perror+          Installed.ParseOk warns ipkg -> return (warns, ipkg)++      unless (null warns) $+        warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)++      return ipkg+  where+    pkgConfParseFailed :: Installed.PError -> IO a+    pkgConfParseFailed perror =+      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+            ++ show perror+
+ cabal/cabal-install/Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable #-}++-- | Handling project configuration.+--+module Distribution.Client.ProjectConfig (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    PackageConfig(..),++    -- * Project config files+    findProjectRoot,+    readProjectConfig,+    writeProjectLocalExtraConfig,+    writeProjectConfigFile,+    commandLineFlagsToProjectConfig,++    -- * Packages within projects+    ProjectPackageLocation(..),+    BadPackageLocation(..),+    BadPackageLocationMatch(..),+    findProjectPackages,+    readSourcePackage,++    -- * Resolving configuration+    lookupLocalPackageConfig,+    projectConfigWithBuilderRepoContext,+    projectConfigWithSolverRepoContext,+    SolverSettings(..),+    resolveSolverSettings,+    BuildTimeSettings(..),+    resolveBuildTimeSettings,+  ) where++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.ProjectConfig.Legacy+import Distribution.Client.RebuildMonad+import Distribution.Client.Glob+         ( isTrivialFilePathGlob )++import Distribution.Client.Types+import Distribution.Client.DistDirLayout+         ( CabalDirLayout(..) )+import Distribution.Client.GlobalFlags+         ( RepoContext(..), withRepoContext' )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Config+         ( loadConfig, defaultConfigFile )++import Distribution.Package+         ( PackageName, PackageId, packageId, UnitId, Dependency )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( SourceRepo(..) )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, flagToMaybe, flagToList+         , fromFlag, AllowNewer(..) )+import Distribution.Client.Setup+         ( defaultSolver, defaultMaxBackjumps, )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , toPathTemplate, substPathTemplate, initialPathTemplateEnv )+import Distribution.Simple.Utils+         ( die, warn )+import Distribution.Client.Utils+         ( determineNumJobs )+import Distribution.Utils.NubList+         ( fromNubList )+import Distribution.Verbosity+         ( Verbosity, verbose )+import Distribution.Text+import Distribution.ParseUtils+         ( ParseResult(..), locatedErrorMsg, showPWarning )++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Control.Monad.Trans (liftIO)+import Control.Exception+import Data.Typeable+import Data.Maybe+import Data.Either+import qualified Data.Map as Map+import Distribution.Compat.Semigroup+import System.FilePath hiding (combine)+import System.Directory+import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI)+++----------------------------------------+-- Resolving configuration to settings+--++-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific+-- 'PackageName'. This returns the configuration that applies to all local+-- packages plus any package-specific configuration for this package.+--+lookupLocalPackageConfig :: (Semigroup a, Monoid a)+                         => (PackageConfig -> a)+                         -> ProjectConfig+                         -> PackageName -> a+lookupLocalPackageConfig field ProjectConfig {+                           projectConfigLocalPackages,+                           projectConfigSpecificPackage+                         } pkgname =+    field projectConfigLocalPackages+ <> maybe mempty field (Map.lookup pkgname projectConfigSpecificPackage)+++-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.+--+projectConfigWithBuilderRepoContext :: Verbosity+                                    -> BuildTimeSettings+                                    -> (RepoContext -> IO a) -> IO a+projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =+    withRepoContext'+      verbosity+      buildSettingRemoteRepos+      buildSettingLocalRepos+      buildSettingCacheDir+      buildSettingHttpTransport+      (Just buildSettingIgnoreExpiry)+++-- | Use a 'RepoContext', but only for the solver. The solver does not use the+-- full facilities of the 'RepoContext' so we can get away with making one+-- that doesn't have an http transport. And that avoids having to have access+-- to the 'BuildTimeSettings'+--+projectConfigWithSolverRepoContext :: Verbosity+                                   -> FilePath+                                   -> ProjectConfigShared+                                   -> ProjectConfigBuildOnly+                                   -> (RepoContext -> IO a) -> IO a+projectConfigWithSolverRepoContext verbosity downloadCacheRootDir+                                   ProjectConfigShared{..}+                                   ProjectConfigBuildOnly{..} =+    withRepoContext'+      verbosity+      (fromNubList projectConfigRemoteRepos)+      (fromNubList projectConfigLocalRepos)+      downloadCacheRootDir+      (flagToMaybe projectConfigHttpTransport)+      (flagToMaybe projectConfigIgnoreExpiry)+++-- | Resolve the project configuration, with all its optional fields, into+-- 'SolverSettings' with no optional fields (by applying defaults).+--+resolveSolverSettings :: ProjectConfigShared -> SolverSettings+resolveSolverSettings projectConfig =+    SolverSettings {..}+  where+    solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos+    solverSettingLocalRepos        = fromNubList projectConfigLocalRepos+    solverSettingConstraints       = projectConfigConstraints+    solverSettingPreferences       = projectConfigPreferences+    solverSettingFlagAssignment    = projectConfigFlagAssignment+    solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion+    solverSettingSolver            = fromFlag projectConfigSolver+    solverSettingAllowNewer        = fromJust projectConfigAllowNewer+    solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of+                                       n | n < 0     -> Nothing+                                         | otherwise -> Just n+    solverSettingReorderGoals      = fromFlag projectConfigReorderGoals+    solverSettingStrongFlags       = fromFlag projectConfigStrongFlags+  --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals+  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs+  --solverSettingReinstall         = fromFlag projectConfigReinstall+  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls+  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall+  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps++    ProjectConfigShared {..} = defaults <> projectConfig++    defaults = mempty {+       projectConfigSolver            = Flag defaultSolver,+       projectConfigAllowNewer        = Just AllowNewerNone,+       projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,+       projectConfigReorderGoals      = Flag False,+       projectConfigStrongFlags       = Flag False+     --projectConfigIndependentGoals  = Flag False,+     --projectConfigShadowPkgs        = Flag False,+     --projectConfigReinstall         = Flag False,+     --projectConfigAvoidReinstalls   = Flag False,+     --projectConfigOverrideReinstall = Flag False,+     --projectConfigUpgradeDeps       = Flag False+    }+++-- | Resolve the project configuration, with all its optional fields, into+-- 'BuildTimeSettings' with no optional fields (by applying defaults).+--+resolveBuildTimeSettings :: Verbosity+                         -> CabalDirLayout+                         -> ProjectConfigShared+                         -> ProjectConfigBuildOnly+                         -> ProjectConfigBuildOnly+                         -> BuildTimeSettings+resolveBuildTimeSettings verbosity+                         CabalDirLayout {+                           cabalLogsDirectory,+                           cabalPackageCacheDirectory+                         }+                         ProjectConfigShared {+                           projectConfigRemoteRepos,+                           projectConfigLocalRepos+                         }+                         fromProjectFile+                         fromCommandLine =+    BuildTimeSettings {..}+  where+    buildSettingDryRun        = fromFlag    projectConfigDryRun+    buildSettingOnlyDeps      = fromFlag    projectConfigOnlyDeps+    buildSettingSummaryFile   = fromNubList projectConfigSummaryFile+    --buildSettingLogFile       -- defined below, more complicated+    --buildSettingLogVerbosity  -- defined below, more complicated+    buildSettingBuildReports  = fromFlag    projectConfigBuildReports+    buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir+    buildSettingOneShot       = fromFlag    projectConfigOneShot+    buildSettingNumJobs       = determineNumJobs projectConfigNumJobs+    buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode+    buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles+    buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos+    buildSettingLocalRepos    = fromNubList projectConfigLocalRepos+    buildSettingCacheDir      = cabalPackageCacheDirectory+    buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport+    buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry+    buildSettingReportPlanningFailure+                              = fromFlag projectConfigReportPlanningFailure+    buildSettingRootCmd       = flagToMaybe projectConfigRootCmd++    ProjectConfigBuildOnly{..} = defaults+                              <> fromProjectFile+                              <> fromCommandLine++    defaults = mempty {+      projectConfigDryRun                = toFlag False,+      projectConfigOnlyDeps              = toFlag False,+      projectConfigBuildReports          = toFlag NoReports,+      projectConfigReportPlanningFailure = toFlag False,+      projectConfigOneShot               = toFlag False,+      projectConfigOfflineMode           = toFlag False,+      projectConfigKeepTempFiles         = toFlag False,+      projectConfigIgnoreExpiry          = toFlag False+    }++    -- The logging logic: what log file to use and what verbosity.+    --+    -- If the user has specified --remote-build-reporting=detailed, use the+    -- default log file location. If the --build-log option is set, use the+    -- provided location. Otherwise don't use logging, unless building in+    -- parallel (in which case the default location is used).+    --+    buildSettingLogFile :: Maybe (Compiler -> Platform+                               -> PackageId -> UnitId -> FilePath)+    buildSettingLogFile+      | useDefaultTemplate = Just (substLogFileName defaultTemplate)+      | otherwise          = fmap  substLogFileName givenTemplate++    defaultTemplate = toPathTemplate $+                        cabalLogsDirectory </> "$pkgid" <.> "log"+    givenTemplate   = flagToMaybe projectConfigLogFile++    useDefaultTemplate+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = False+      | isParallelBuild                             = True+      | otherwise                                   = False++    isParallelBuild = buildSettingNumJobs >= 2++    substLogFileName :: PathTemplate+                     -> Compiler -> Platform+                     -> PackageId -> UnitId -> FilePath+    substLogFileName template compiler platform pkgid uid =+        fromPathTemplate (substPathTemplate env template)+      where+        env = initialPathTemplateEnv+                pkgid uid (compilerInfo compiler) platform++    -- If the user has specified --remote-build-reporting=detailed or+    -- --build-log, use more verbose logging.+    --+    buildSettingLogVerbosity+      | overrideVerbosity = max verbose verbosity+      | otherwise         = verbosity++    overrideVerbosity+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = True+      | isParallelBuild                             = False+      | otherwise                                   = False+++---------------------------------------------+-- Reading and writing project config files+--++-- | Find the root of this project.+--+-- Searches for an explicit @cabal.project@ file, in the current directory or+-- parent directories. If no project file is found then the current dir is the+-- project root (and the project will use an implicit config).+--+findProjectRoot :: IO FilePath+findProjectRoot = do++    curdir  <- getCurrentDirectory+    homedir <- getHomeDirectory++    -- Search upwards. If we get to the users home dir or the filesystem root,+    -- then use the current dir+    let probe dir | isDrive dir || dir == homedir+                  = return curdir -- implicit project root+        probe dir = do+          exists <- doesFileExist (dir </> "cabal.project")+          if exists+            then return dir       -- explicit project root+            else probe (takeDirectory dir)++    probe curdir+   --TODO: [nice to have] add compat support for old style sandboxes+++-- | Read all the config relevant for a project. This includes the project+-- file if any, plus other global config.+--+readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig+readProjectConfig verbosity projectRootDir = do+    global <- readGlobalConfig verbosity+    local  <- readProjectLocalConfig      verbosity projectRootDir+    extra  <- readProjectLocalExtraConfig verbosity projectRootDir+    return (global <> local <> extra)+++-- | Reads an explicit @cabal.project@ file in the given project root dir,+-- or returns the default project config for an implicitly defined project.+--+readProjectLocalConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig+readProjectLocalConfig verbosity projectRootDir = do+  usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile+  if usesExplicitProjectRoot+    then do+      monitorFiles [monitorFileHashed projectFile]+      liftIO readProjectFile+    else do+      monitorFiles [monitorNonExistentFile projectFile]+      return defaultImplicitProjectConfig++  where+    projectFile = projectRootDir </> "cabal.project"+    readProjectFile =+          reportParseResult verbosity "project file" projectFile+        . parseProjectConfig+      =<< readFile projectFile++    defaultImplicitProjectConfig :: ProjectConfig+    defaultImplicitProjectConfig =+      mempty {+        -- We expect a package in the current directory.+        projectPackages         = [ "./*.cabal" ],++        -- This is to automatically pick up deps that we unpack locally.+        projectPackagesOptional = [ "./*/*.cabal" ]+      }+++-- | Reads a @cabal.project.extra@ file in the given project root dir,+-- or returns empty. This file gets written by @cabal configure@, or in+-- principle can be edited manually or by other tools.+--+readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig+readProjectLocalExtraConfig verbosity projectRootDir = do+    hasExtraConfig <- liftIO $ doesFileExist projectExtraConfigFile+    if hasExtraConfig+      then do monitorFiles [monitorFileHashed projectExtraConfigFile]+              liftIO readProjectExtraConfigFile+      else do monitorFiles [monitorNonExistentFile projectExtraConfigFile]+              return mempty+  where+    projectExtraConfigFile = projectRootDir </> "cabal.project.extra"++    readProjectExtraConfigFile =+          reportParseResult verbosity "project extra configuration file"+                            projectExtraConfigFile+        . parseProjectConfig+      =<< readFile projectExtraConfigFile+++-- | Parse the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of parsers for legacy+-- configuration types, plus a conversion.+--+parseProjectConfig :: String -> ParseResult ProjectConfig+parseProjectConfig content =+    convertLegacyProjectConfig <$>+      parseLegacyProjectConfig content+++-- | Render the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of a pretty printer for the+-- legacy configuration types, plus a conversion.+--+showProjectConfig :: ProjectConfig -> String+showProjectConfig =+    showLegacyProjectConfig . convertToLegacyProjectConfig+++-- | Write a @cabal.project.extra@ file in the given project root dir.+--+writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO ()+writeProjectLocalExtraConfig projectRootDir =+    writeProjectConfigFile projectExtraConfigFile+  where+    projectExtraConfigFile = projectRootDir </> "cabal.project.extra"+++-- | Write in the @cabal.project@ format to the given file.+--+writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()+writeProjectConfigFile file =+    writeFile file . showProjectConfig+++-- | Read the user's @~/.cabal/config@ file.+--+readGlobalConfig :: Verbosity -> Rebuild ProjectConfig+readGlobalConfig verbosity = do+    config     <- liftIO (loadConfig verbosity mempty)+    configFile <- liftIO defaultConfigFile+    monitorFiles [monitorFileHashed configFile]+    return (convertLegacyGlobalConfig config)+    --TODO: do this properly, there's several possible locations+    -- and env vars, and flags for selecting the global config+++reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a+reportParseResult verbosity _filetype filename (ParseOk warnings x) = do+    unless (null warnings) $+      let msg = unlines (map (showPWarning filename) warnings)+       in warn verbosity msg+    return x+reportParseResult _verbosity filetype filename (ParseFailed err) =+    let (line, msg) = locatedErrorMsg err+     in die $ "Error parsing " ++ filetype ++ " " ++ filename+           ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+++---------------------------------------------+-- Reading packages in the project+--++data ProjectPackageLocation =+     ProjectPackageLocalCabalFile FilePath+   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file+   | ProjectPackageLocalTarball   FilePath+   | ProjectPackageRemoteTarball  URI+   | ProjectPackageRemoteRepo     SourceRepo+   | ProjectPackageNamed          Dependency+  deriving Show+++-- | Exception thrown by 'findProjectPackages'.+--+newtype BadPackageLocations = BadPackageLocations [BadPackageLocation]+  deriving (Show, Typeable)++instance Exception BadPackageLocations+--TODO: [required eventually] displayException for nice rendering+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++data BadPackageLocation+   = BadPackageLocationFile    BadPackageLocationMatch+   | BadLocGlobEmptyMatch      String+   | BadLocGlobBadMatches      String [BadPackageLocationMatch]+   | BadLocUnexpectedUriScheme String+   | BadLocUnrecognisedUri     String+   | BadLocUnrecognised        String+  deriving Show++data BadPackageLocationMatch+   = BadLocUnexpectedFile      String+   | BadLocNonexistantFile     String+   | BadLocDirNoCabalFile      String+   | BadLocDirManyCabalFiles   String+  deriving Show+++-- | Given the project config,+--+-- Throws 'BadPackageLocations'.+--+findProjectPackages :: FilePath -> ProjectConfig+                    -> Rebuild [ProjectPackageLocation]+findProjectPackages projectRootDir ProjectConfig{..} = do++    requiredPkgs <- findPackageLocations True    projectPackages+    optionalPkgs <- findPackageLocations False   projectPackagesOptional+    let repoPkgs  = map ProjectPackageRemoteRepo projectPackagesRepo+        namedPkgs = map ProjectPackageNamed      projectPackagesNamed++    return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])+  where+    findPackageLocations required pkglocstr = do+      (problems, pkglocs) <-+        partitionEithers <$> mapM (findPackageLocation required) pkglocstr+      unless (null problems) $+        liftIO $ throwIO $ BadPackageLocations problems+      return (concat pkglocs)+++    findPackageLocation :: Bool -> String+                        -> Rebuild (Either BadPackageLocation+                                          [ProjectPackageLocation])+    findPackageLocation _required@True pkglocstr =+      -- strategy: try first as a file:// or http(s):// URL.+      -- then as a file glob (usually encompassing single file)+      -- finally as a single file, for files that fail to parse as globs+                    checkIsUriPackage pkglocstr+      `mplusMaybeT` checkIsFileGlobPackage pkglocstr+      `mplusMaybeT` checkIsSingleFilePackage pkglocstr+      >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return+++    findPackageLocation _required@False pkglocstr = do+      -- just globs for optional case+      res <- checkIsFileGlobPackage pkglocstr+      case res of+        Nothing              -> return (Left (BadLocUnrecognised pkglocstr))+        Just (Left _)        -> return (Right []) -- it's optional+        Just (Right pkglocs) -> return (Right pkglocs)+++    checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage+      :: String -> Rebuild (Maybe (Either BadPackageLocation+                                         [ProjectPackageLocation]))+    checkIsUriPackage pkglocstr =+      return $!+      case parseAbsoluteURI pkglocstr of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host }+          }+          | recognisedScheme && not (null host) ->+            Just (Right [ProjectPackageRemoteTarball uri])++          | not recognisedScheme && not (null host) ->+            Just (Left (BadLocUnexpectedUriScheme pkglocstr))++          | recognisedScheme && null host ->+            Just (Left (BadLocUnrecognisedUri pkglocstr))+          where+            recognisedScheme = scheme == "http:" || scheme == "https:"+                            || scheme == "file:"++        _ -> Nothing+++    checkIsFileGlobPackage pkglocstr =+      case simpleParse pkglocstr of+        Nothing   -> return Nothing+        Just glob -> liftM Just $ do+          matches <- matchFileGlob projectRootDir glob+          case matches of+            [] | isJust (isTrivialFilePathGlob glob)+               -> return (Left (BadPackageLocationFile+                                  (BadLocNonexistantFile pkglocstr)))++            [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))++            _  -> do+              (failures, pkglocs) <- partitionEithers <$>+                                     mapM checkFilePackageMatch matches+              if null pkglocs+                then return (Left (BadLocGlobBadMatches pkglocstr failures))+                else return (Right pkglocs)+++    checkIsSingleFilePackage pkglocstr = do+      let filename = projectRootDir </> pkglocstr+      isFile <- liftIO $ doesFileExist filename+      isDir  <- liftIO $ doesDirectoryExist filename+      if isFile || isDir+        then checkFilePackageMatch pkglocstr+         >>= either (return . Just . Left  . BadPackageLocationFile)+                    (return . Just . Right . (\x->[x]))+        else return Nothing+++    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch+                                                       ProjectPackageLocation)+    checkFilePackageMatch pkglocstr = do+      let filename = projectRootDir </> pkglocstr+      isDir  <- liftIO $ doesDirectoryExist filename+      parentDirExists <- case takeDirectory filename of+                           []  -> return False+                           dir -> liftIO $ doesDirectoryExist dir+      case () of+        _ | isDir+         -> do let dirname = filename -- now we know its a dir+                   glob    = globStarDotCabal pkglocstr+               matches <- matchFileGlob projectRootDir glob+               case matches of+                 [match]+                     -> return (Right (ProjectPackageLocalDirectory+                                         dirname cabalFile))+                   where+                     cabalFile = dirname </> match+                 []  -> return (Left (BadLocDirNoCabalFile pkglocstr))+                 _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))++          | extensionIsTarGz filename+         -> return (Right (ProjectPackageLocalTarball filename))++          | takeExtension filename == ".cabal"+         -> return (Right (ProjectPackageLocalCabalFile filename))++          | parentDirExists+         -> return (Left (BadLocNonexistantFile pkglocstr))++          | otherwise+         -> return (Left (BadLocUnexpectedFile pkglocstr))+++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"+++globStarDotCabal :: FilePath -> FilePathGlob+globStarDotCabal =+    FilePathGlob FilePathRelative+  . foldr (\dirpart -> GlobDir [Literal dirpart])+          (GlobFile [WildCard, Literal ".cabal"])+  . splitDirectories+++--TODO: [code cleanup] use sufficiently recent transformers package+mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+mplusMaybeT ma mb = do+  mx <- ma+  case mx of+    Nothing -> mb+    Just x  -> return (Just x)+++readSourcePackage :: Verbosity -> ProjectPackageLocation+                  -> Rebuild UnresolvedSourcePackage+readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =+    readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile)+  where+    dir = takeDirectory cabalFile++readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do+    -- no need to monitorFiles because findProjectCabalFiles did it already+    pkgdesc <- liftIO $ readPackageDescription verbosity cabalFile+    return SourcePackage {+      packageInfoId        = packageId pkgdesc,+      packageDescription   = pkgdesc,+      packageSource        = LocalUnpackedPackage dir,+      packageDescrOverride = Nothing+    }+readSourcePackage _verbosity _ =+    fail $ "TODO: add support for fetching and reading local tarballs, remote "+        ++ "tarballs, remote repos and passing named packages through"
+ cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs view
@@ -0,0 +1,1251 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveGeneric #-}++-- | Project configuration, implementation in terms of legacy types.+--+module Distribution.Client.ProjectConfig.Legacy (++    -- * Project config in terms of legacy types+    LegacyProjectConfig,+    parseLegacyProjectConfig,+    showLegacyProjectConfig,++    -- * Conversion to and from legacy config types+    commandLineFlagsToProjectConfig,+    convertLegacyProjectConfig,+    convertLegacyGlobalConfig,+    convertToLegacyProjectConfig,++    -- * Internals, just for tests+    parsePackageLocationTokenQ,+    renderPackageLocationToken,+  ) where++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.Types+         ( RemoteRepo(..), emptyRemoteRepo )+import Distribution.Client.Dependency.Types+         ( ConstraintSource(..) )+import Distribution.Client.Config+         ( SavedConfig(..), remoteRepoFields )++import Distribution.Package+import Distribution.PackageDescription+         ( SourceRepo(..), RepoKind(..) )+import Distribution.PackageDescription.Parse+         ( sourceRepoFieldDescrs )+import Distribution.Simple.Compiler+         ( OptimisationLevel(..), DebugInfoLevel(..) )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, fromFlagOrDefault+         , ConfigFlags(..), configureOptions+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags+         , programConfigurationPaths', splitArgs+         , AllowNewer(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , InstallFlags(..), installOptions, defaultInstallFlags )+import Distribution.Simple.Program+         ( programName, knownPrograms )+import Distribution.Simple.Program.Db+         ( ProgramDb, defaultProgramDb )+import Distribution.Client.Targets+         ( dispFlagAssignment, parseFlagAssignment )+import Distribution.Simple.Utils+         ( lowercase )+import Distribution.Utils.NubList+         ( toNubList, fromNubList, overNubList )+import Distribution.Simple.LocalBuildInfo+         ( toPathTemplate, fromPathTemplate )++import Distribution.Text+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( ReadP, (+++), (<++) )+import qualified Text.Read as Read+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( Doc, ($+$) )+import qualified Distribution.ParseUtils as ParseUtils (field)+import Distribution.ParseUtils+         ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning+         , simpleField, commaNewLineListField+         , showToken )+import Distribution.Client.ParseUtils+import Distribution.Simple.Command+         ( CommandUI(commandOptions), ShowOrParseArgs(..)+         , OptionField, option, reqArg' )++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Char (isSpace)+import Distribution.Compat.Semigroup+import GHC.Generics (Generic)++------------------------------------------------------------------+-- Representing the project config file in terms of legacy types+--++-- | We already have parsers\/pretty-printers for almost all the fields in the+-- project config file, but they're in terms of the types used for the command+-- line flags for Setup.hs or cabal commands. We don't want to redefine them+-- all, at least not yet so for the moment we use the parsers at the old types+-- and use conversion functions.+--+-- Ultimately if\/when this project-based approach becomes the default then we+-- can redefine the parsers directly for the new types.+--+data LegacyProjectConfig = LegacyProjectConfig {+       legacyPackages          :: [String],+       legacyPackagesOptional  :: [String],+       legacyPackagesRepo      :: [SourceRepo],+       legacyPackagesNamed     :: [Dependency],++       legacySharedConfig      :: LegacySharedConfig,+       legacyLocalConfig       :: LegacyPackageConfig,+       legacySpecificConfig    :: Map PackageName LegacyPackageConfig+     } deriving Generic++instance Monoid LegacyProjectConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyProjectConfig where+  (<>) = gmappend++data LegacyPackageConfig = LegacyPackageConfig {+       legacyConfigureFlags    :: ConfigFlags,+       legacyInstallPkgFlags   :: InstallFlags,+       legacyHaddockFlags      :: HaddockFlags+     } deriving Generic++instance Monoid LegacyPackageConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyPackageConfig where+  (<>) = gmappend++data LegacySharedConfig = LegacySharedConfig {+       legacyGlobalFlags       :: GlobalFlags,+       legacyConfigureShFlags  :: ConfigFlags,+       legacyConfigureExFlags  :: ConfigExFlags,+       legacyInstallFlags      :: InstallFlags+     } deriving Generic++instance Monoid LegacySharedConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacySharedConfig where+  (<>) = gmappend+++------------------------------------------------------------------+-- Converting from and to the legacy types+--++-- | Convert configuration from the @cabal configure@ or @cabal build@ command+-- line into a 'ProjectConfig' value that can combined with configuration from+-- other sources.+--+-- At the moment this uses the legacy command line flag types. See+-- 'LegacyProjectConfig' for an explanation.+--+commandLineFlagsToProjectConfig :: GlobalFlags+                                -> ConfigFlags  -> ConfigExFlags+                                -> InstallFlags -> HaddockFlags+                                -> ProjectConfig+commandLineFlagsToProjectConfig globalFlags configFlags configExFlags+                                installFlags haddockFlags =+    mempty {+      projectConfigBuildOnly     = convertLegacyBuildOnlyFlags+                                     globalFlags configFlags+                                     installFlags haddockFlags,+      projectConfigShared        = convertLegacyAllPackageFlags+                                     globalFlags configFlags+                                     configExFlags installFlags,+      projectConfigLocalPackages = convertLegacyPerPackageFlags+                                     configFlags installFlags haddockFlags+    }+++-- | Convert from the types currently used for the user-wide @~/.cabal/config@+-- file into the 'ProjectConfig' type.+--+-- Only a subset of the 'ProjectConfig' can be represented in the user-wide+-- config. In particular it does not include packages that are in the project,+-- and it also doesn't support package-specific configuration (only+-- configuration that applies to all packages).+--+convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig+convertLegacyGlobalConfig+    SavedConfig {+      savedGlobalFlags       = globalFlags,+      savedInstallFlags      = installFlags,+      savedConfigureFlags    = configFlags,+      savedConfigureExFlags  = configExFlags,+      savedUserInstallDirs   = _,+      savedGlobalInstallDirs = _,+      savedUploadFlags       = _,+      savedReportFlags       = _,+      savedHaddockFlags      = haddockFlags+    } =+    mempty {+      projectConfigShared        = configAllPackages,+      projectConfigLocalPackages = configLocalPackages,+      projectConfigBuildOnly     = configBuildOnly+    }+  where+    --TODO: [code cleanup] eliminate use of default*Flags here and specify the+    -- defaults in the various resolve functions in terms of the new types.+    configExFlags' = defaultConfigExFlags <> configExFlags+    installFlags'  = defaultInstallFlags  <> installFlags+    haddockFlags'  = defaultHaddockFlags  <> haddockFlags++    configLocalPackages = convertLegacyPerPackageFlags+                            configFlags installFlags' haddockFlags'+    configAllPackages   = convertLegacyAllPackageFlags+                            globalFlags configFlags+                            configExFlags' installFlags'+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configFlags+                            installFlags' haddockFlags'+++-- | Convert the project config from the legacy types to the 'ProjectConfig'+-- and associated types. See 'LegacyProjectConfig' for an explanation of the+-- approach.+--+convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig+convertLegacyProjectConfig+  LegacyProjectConfig {+    legacyPackages,+    legacyPackagesOptional,+    legacyPackagesRepo,+    legacyPackagesNamed,+    legacySharedConfig = LegacySharedConfig globalFlags configShFlags+                                            configExFlags installSharedFlags,+    legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags+                                             haddockFlags,+    legacySpecificConfig+  } =++    ProjectConfig {+      projectPackages              = legacyPackages,+      projectPackagesOptional      = legacyPackagesOptional,+      projectPackagesRepo          = legacyPackagesRepo,+      projectPackagesNamed         = legacyPackagesNamed,++      projectConfigBuildOnly       = configBuildOnly,+      projectConfigShared          = configAllPackages,+      projectConfigLocalPackages   = configLocalPackages,+      projectConfigSpecificPackage = fmap perPackage legacySpecificConfig+    }+  where+    configLocalPackages = convertLegacyPerPackageFlags+                            configFlags installPerPkgFlags haddockFlags+    configAllPackages   = convertLegacyAllPackageFlags+                            globalFlags (configFlags <> configShFlags)+                            configExFlags installSharedFlags+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configShFlags+                            installSharedFlags haddockFlags++    perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags+                                    perPkgHaddockFlags) =+      convertLegacyPerPackageFlags+        perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags+++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigShared' subset of the 'ProjectConfig'.+--+convertLegacyAllPackageFlags :: GlobalFlags -> ConfigFlags+                             -> ConfigExFlags -> InstallFlags+                             -> ProjectConfigShared+convertLegacyAllPackageFlags globalFlags configFlags+                             configExFlags installFlags =+    ProjectConfigShared{..}+  where+    GlobalFlags {+      globalConfigFile        = _, -- TODO: [required feature]+      globalSandboxConfigFile = _, -- ??+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalLocalRepos        = projectConfigLocalRepos+    } = globalFlags++    ConfigFlags {+      configProgramPaths,+      configProgramArgs,+      configProgramPathExtra    = projectConfigProgramPathExtra,+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg,+    --configInstallDirs         = projectConfigInstallDirs,+    --configUserInstall         = projectConfigUserInstall,+    --configPackageDBs          = projectConfigPackageDBs,+      configConfigurationsFlags = projectConfigFlagAssignment,+      configAllowNewer          = projectConfigAllowNewer+    } = configFlags+    projectConfigProgramPaths   = Map.fromList configProgramPaths+    projectConfigProgramArgs    = Map.fromList configProgramArgs++    ConfigExFlags {+      configCabalVersion        = projectConfigCabalVersion,+      configExConstraints       = projectConfigConstraints,+      configPreferences         = projectConfigPreferences,+      configSolver              = projectConfigSolver+    } = configExFlags++    InstallFlags {+      installHaddockIndex       = projectConfigHaddockIndex,+    --installReinstall          = projectConfigReinstall,+    --installAvoidReinstalls    = projectConfigAvoidReinstalls,+    --installOverrideReinstall  = projectConfigOverrideReinstall,+      installMaxBackjumps       = projectConfigMaxBackjumps,+    --installUpgradeDeps        = projectConfigUpgradeDeps,+      installReorderGoals       = projectConfigReorderGoals,+    --installIndependentGoals   = projectConfigIndependentGoals,+    --installShadowPkgs         = projectConfigShadowPkgs,+      installStrongFlags        = projectConfigStrongFlags+    } = installFlags++++-- | Helper used by other conversion functions that returns the+-- 'PackageConfig' subset of the 'ProjectConfig'.+--+convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags+                             -> PackageConfig+convertLegacyPerPackageFlags configFlags installFlags haddockFlags =+    PackageConfig{..}+  where+    ConfigFlags {+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configDynExe              = packageConfigDynExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configConfigurationsFlags = _projectConfigFlagAssignment, --TODO: should be per pkg+      configTests               = packageConfigTests,+      configBenchmarks          = packageConfigBenchmarks,+      configCoverage            = coverage,+      configLibCoverage         = libcoverage, --deprecated+      configDebugInfo           = packageConfigDebugInfo,+      configRelocatable         = packageConfigRelocatable+    } = configFlags++    packageConfigCoverage       = coverage <> libcoverage+    --TODO: defer this merging to the resolve phase++    InstallFlags {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    } = installFlags++    HaddockFlags {+      haddockHoogle             = packageConfigHaddockHoogle,+      haddockHtml               = packageConfigHaddockHtml,+      haddockHtmlLocation       = packageConfigHaddockHtmlLocation,+      haddockExecutables        = packageConfigHaddockExecutables,+      haddockTestSuites         = packageConfigHaddockTestSuites,+      haddockBenchmarks         = packageConfigHaddockBenchmarks,+      haddockInternal           = packageConfigHaddockInternal,+      haddockCss                = packageConfigHaddockCss,+      haddockHscolour           = packageConfigHaddockHscolour,+      haddockHscolourCss        = packageConfigHaddockHscolourCss,+      haddockContents           = packageConfigHaddockContents+    } = haddockFlags++++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.+--+convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags+                            -> InstallFlags -> HaddockFlags+                            -> ProjectConfigBuildOnly+convertLegacyBuildOnlyFlags globalFlags configFlags+                              installFlags haddockFlags =+    ProjectConfigBuildOnly{..}+  where+    GlobalFlags {+      globalCacheDir          = projectConfigCacheDir,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = projectConfigWorldFile,+      globalHttpTransport     = projectConfigHttpTransport,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry+    } = globalFlags++    ConfigFlags {+      configVerbosity           = projectConfigVerbosity+    } = configFlags++    InstallFlags {+      installDryRun             = projectConfigDryRun,+      installOnly               = _,+      installOnlyDeps           = projectConfigOnlyDeps,+      installRootCmd            = projectConfigRootCmd,+      installSummaryFile        = projectConfigSummaryFile,+      installLogFile            = projectConfigLogFile,+      installBuildReports       = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir      = projectConfigSymlinkBinDir,+      installOneShot            = projectConfigOneShot,+      installNumJobs            = projectConfigNumJobs,+      installOfflineMode        = projectConfigOfflineMode+    } = installFlags++    HaddockFlags {+      haddockKeepTempFiles      = projectConfigKeepTempFiles --TODO: this ought to live elsewhere+    } = haddockFlags+++convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig+convertToLegacyProjectConfig+    projectConfig@ProjectConfig {+      projectPackages,+      projectPackagesOptional,+      projectPackagesRepo,+      projectPackagesNamed,+      projectConfigLocalPackages,+      projectConfigSpecificPackage+    } =+    LegacyProjectConfig {+      legacyPackages         = projectPackages,+      legacyPackagesOptional = projectPackagesOptional,+      legacyPackagesRepo     = projectPackagesRepo,+      legacyPackagesNamed    = projectPackagesNamed,+      legacySharedConfig     = convertToLegacySharedConfig projectConfig,+      legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig+                            <> convertToLegacyPerPackageConfig+                                 projectConfigLocalPackages,+      legacySpecificConfig   = fmap convertToLegacyPerPackageConfig+                                    projectConfigSpecificPackage+    }++convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig+convertToLegacySharedConfig+    ProjectConfig {+      projectConfigBuildOnly     = ProjectConfigBuildOnly {..},+      projectConfigShared        = ProjectConfigShared {..}+    } =++    LegacySharedConfig {+      legacyGlobalFlags      = globalFlags,+      legacyConfigureShFlags = configFlags,+      legacyConfigureExFlags = configExFlags,+      legacyInstallFlags     = installFlags+    }+  where+    globalFlags = GlobalFlags {+      globalVersion           = mempty,+      globalNumericVersion    = mempty,+      globalConfigFile        = mempty,+      globalSandboxConfigFile = mempty,+      globalConstraintsFile   = mempty,+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalCacheDir          = projectConfigCacheDir,+      globalLocalRepos        = projectConfigLocalRepos,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = projectConfigWorldFile,+      globalRequireSandbox    = mempty,+      globalIgnoreSandbox     = mempty,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry,+      globalHttpTransport     = projectConfigHttpTransport+    }++    configFlags = mempty {+      configVerbosity     = projectConfigVerbosity,+      configAllowNewer    = projectConfigAllowNewer+    }++    configExFlags = ConfigExFlags {+      configCabalVersion  = projectConfigCabalVersion,+      configExConstraints = projectConfigConstraints,+      configPreferences   = projectConfigPreferences,+      configSolver        = projectConfigSolver+    }++    installFlags = InstallFlags {+      installDocumentation     = mempty,+      installHaddockIndex      = projectConfigHaddockIndex,+      installDryRun            = projectConfigDryRun,+      installReinstall         = mempty, --projectConfigReinstall,+      installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,+      installOverrideReinstall = mempty, --projectConfigOverrideReinstall,+      installMaxBackjumps      = projectConfigMaxBackjumps,+      installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,+      installReorderGoals      = projectConfigReorderGoals,+      installIndependentGoals  = mempty, --projectConfigIndependentGoals,+      installShadowPkgs        = mempty, --projectConfigShadowPkgs,+      installStrongFlags       = projectConfigStrongFlags,+      installOnly              = mempty,+      installOnlyDeps          = projectConfigOnlyDeps,+      installRootCmd           = projectConfigRootCmd,+      installSummaryFile       = projectConfigSummaryFile,+      installLogFile           = projectConfigLogFile,+      installBuildReports      = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir     = projectConfigSymlinkBinDir,+      installOneShot           = projectConfigOneShot,+      installNumJobs           = projectConfigNumJobs,+      installRunTests          = mempty,+      installOfflineMode       = projectConfigOfflineMode+    }+++convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig+convertToLegacyAllPackageConfig+    ProjectConfig {+      projectConfigBuildOnly = ProjectConfigBuildOnly {..},+      projectConfigShared    = ProjectConfigShared {..}+    } =++    LegacyPackageConfig {+      legacyConfigureFlags = configFlags,+      legacyInstallPkgFlags= mempty,+      legacyHaddockFlags   = haddockFlags+    }+  where+    configFlags = ConfigFlags {+      configPrograms_           = mempty,+      configProgramPaths        = Map.toList projectConfigProgramPaths,+      configProgramArgs         = Map.toList projectConfigProgramArgs,+      configProgramPathExtra    = projectConfigProgramPathExtra,+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg,+      configVanillaLib          = mempty,+      configProfLib             = mempty,+      configSharedLib           = mempty,+      configDynExe              = mempty,+      configProfExe             = mempty,+      configProf                = mempty,+      configProfDetail          = mempty,+      configProfLibDetail       = mempty,+      configConfigureArgs       = mempty,+      configOptimization        = mempty,+      configProgPrefix          = mempty,+      configProgSuffix          = mempty,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty, --projectConfigUserInstall,+      configPackageDBs          = mempty, --projectConfigPackageDBs,+      configGHCiLib             = mempty,+      configSplitObjs           = mempty,+      configStripExes           = mempty,+      configStripLibs           = mempty,+      configExtraLibDirs        = mempty,+      configExtraFrameworkDirs  = mempty,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = mempty,+      configIPID                = mempty,+      configConfigurationsFlags = projectConfigFlagAssignment,+      configTests               = mempty,+      configCoverage            = mempty, --TODO: don't merge+      configLibCoverage         = mempty, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = mempty,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = mempty,+      configDebugInfo           = mempty,+      configAllowNewer          = mempty+    }++    haddockFlags = mempty {+      haddockKeepTempFiles = projectConfigKeepTempFiles+    }+++convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig+convertToLegacyPerPackageConfig PackageConfig {..} =+    LegacyPackageConfig {+      legacyConfigureFlags  = configFlags,+      legacyInstallPkgFlags = installFlags,+      legacyHaddockFlags    = haddockFlags+    }+  where+    configFlags = ConfigFlags {+      configPrograms_           = configPrograms_ mempty,+      configProgramPaths        = mempty,+      configProgramArgs         = mempty,+      configProgramPathExtra    = mempty,+      configHcFlavor            = mempty,+      configHcPath              = mempty,+      configHcPkg               = mempty,+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configDynExe              = packageConfigDynExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty,+      configPackageDBs          = mempty,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configIPID                = mempty,+      configConfigurationsFlags = mempty,+      configTests               = packageConfigTests,+      configCoverage            = packageConfigCoverage, --TODO: don't merge+      configLibCoverage         = packageConfigCoverage, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = packageConfigBenchmarks,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = packageConfigRelocatable,+      configDebugInfo           = packageConfigDebugInfo,+      configAllowNewer          = mempty+    }++    installFlags = mempty {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    }++    haddockFlags = HaddockFlags {+      haddockProgramPaths  = mempty,+      haddockProgramArgs   = mempty,+      haddockHoogle        = packageConfigHaddockHoogle,+      haddockHtml          = packageConfigHaddockHtml,+      haddockHtmlLocation  = packageConfigHaddockHtmlLocation,+      haddockForHackage    = mempty, --TODO: added recently+      haddockExecutables   = packageConfigHaddockExecutables,+      haddockTestSuites    = packageConfigHaddockTestSuites,+      haddockBenchmarks    = packageConfigHaddockBenchmarks,+      haddockInternal      = packageConfigHaddockInternal,+      haddockCss           = packageConfigHaddockCss,+      haddockHscolour      = packageConfigHaddockHscolour,+      haddockHscolourCss   = packageConfigHaddockHscolourCss,+      haddockContents      = packageConfigHaddockContents,+      haddockDistPref      = mempty,+      haddockKeepTempFiles = mempty,+      haddockVerbosity     = mempty+    }+++------------------------------------------------+-- Parsing and showing the project config file+--++parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig+parseLegacyProjectConfig =+    parseConfig legacyProjectConfigFieldDescrs+                legacyPackageConfigSectionDescrs+                mempty++showLegacyProjectConfig :: LegacyProjectConfig -> String+showLegacyProjectConfig config =+    Disp.render $+    showConfig  legacyProjectConfigFieldDescrs+                legacyPackageConfigSectionDescrs+                config+  $+$+    Disp.text ""+++legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig]+legacyProjectConfigFieldDescrs =++    [ newLineListField "packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackages+        (\v flags -> flags { legacyPackages = v })+    , newLineListField "optional-packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackagesOptional+        (\v flags -> flags { legacyPackagesOptional = v })+    , commaNewLineListField "extra-packages"+        disp parse+        legacyPackagesNamed+        (\v flags -> flags { legacyPackagesNamed = v })+    ]++ ++ map (liftField+           legacySharedConfig+           (\flags conf -> conf { legacySharedConfig = flags }))+        legacySharedConfigFieldDescrs++ ++ map (liftField+           legacyLocalConfig+           (\flags conf -> conf { legacyLocalConfig = flags }))+        legacyPackageConfigFieldDescrs++-- | This is a bit tricky since it has to cover globs which have embedded @,@+-- chars. But we don't just want to parse strictly as a glob since we want to+-- allow http urls which don't parse as globs, and possibly some+-- system-dependent file paths. So we parse fairly liberally as a token, but+-- we allow @,@ inside matched @{}@ braces.+--+parsePackageLocationTokenQ :: ReadP r String+parsePackageLocationTokenQ = parseHaskellString+                   Parse.<++ parsePackageLocationToken+  where+    parsePackageLocationToken :: ReadP r String+    parsePackageLocationToken = fmap fst (Parse.gather outerTerm)+      where+        outerTerm   = alternateEither1 outerToken (braces innerTerm)+        innerTerm   = alternateEither  innerToken (braces innerTerm)+        outerToken  = Parse.munch1 outerChar >> return ()+        innerToken  = Parse.munch1 innerChar >> return ()+        outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')+        innerChar c = not (isSpace c || c == '{' || c == '}')+        braces      = Parse.between (Parse.char '{') (Parse.char '}')++    alternateEither, alternateEither1,+      alternatePQs, alternate1PQs, alternateQsP, alternate1QsP+      :: ReadP r () -> ReadP r () -> ReadP r ()++    alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p+    alternateEither  p q = alternateEither1 p q +++ return ()+    alternate1PQs    p q = p >> alternateQsP q p+    alternatePQs     p q = alternate1PQs p q +++ return ()+    alternate1QsP    q p = Parse.many1 q >> alternatePQs p q+    alternateQsP     q p = alternate1QsP q p +++ return ()++renderPackageLocationToken :: String -> String+renderPackageLocationToken s | needsQuoting = show s+                             | otherwise    = s+  where+    needsQuoting  = not (ok 0 s)+                 || s == "." -- . on its own on a line has special meaning+                 || take 2 s == "--" -- on its own line is comment syntax+                 --TODO: [code cleanup] these "." and "--" escaping issues+                 -- ought to be dealt with systematically in ParseUtils.+    ok :: Int -> String -> Bool+    ok n []       = n == 0+    ok _ ('"':_)  = False+    ok n ('{':cs) = ok (n+1) cs+    ok n ('}':cs) = ok (n-1) cs+    ok n (',':cs) = (n > 0) && ok n cs+    ok _ (c:_)+      | isSpace c = False+    ok n (_  :cs) = ok n cs+++legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig]+legacySharedConfigFieldDescrs =++  ( liftFields+      legacyGlobalFlags+      (\flags conf -> conf { legacyGlobalFlags = flags })+  . addFields+      [ newLineListField "local-repo"+          showTokenQ parseTokenQ+          (fromNubList . globalLocalRepos)+          (\v conf -> conf { globalLocalRepos = toNubList v })+      ]+  . filterFields+      [ "remote-repo-cache"+      , "logs-dir", "world-file", "ignore-expiry", "http-transport"+      ]+  . commandOptionsToFields+  ) (commandOptions (globalCommand []) ParseArgs)+ +++  ( liftFields+      legacyConfigureShFlags+      (\flags conf -> conf { legacyConfigureShFlags = flags })+  . addFields+      [ simpleField "allow-newer"+        (maybe mempty dispAllowNewer) (fmap Just parseAllowNewer)+        configAllowNewer (\v conf -> conf { configAllowNewer = v })+      ]+  . filterFields ["verbose"]+  . commandOptionsToFields+  ) (configureOptions ParseArgs)+ +++  ( liftFields+      legacyConfigureExFlags+      (\flags conf -> conf { legacyConfigureExFlags = flags })+  . addFields+      [ commaNewLineListField "constraints"+        (disp . fst) (fmap (\constraint -> (constraint, constraintSrc)) parse)+        configExConstraints (\v conf -> conf { configExConstraints = v })++      , commaNewLineListField "preferences"+        disp parse+        configPreferences (\v conf -> conf { configPreferences = v })+      ]+  . filterFields+      [ "cabal-lib-version", "solver"+        -- not "constraint" or "preference", we use our own plural ones above+      ]+  . commandOptionsToFields+  ) (configureExOptions ParseArgs constraintSrc)+ +++  ( liftFields+      legacyInstallFlags+      (\flags conf -> conf { legacyInstallFlags = flags })+  . addFields+      [ newLineListField "build-summary"+          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+          (fromNubList . installSummaryFile)+          (\v conf -> conf { installSummaryFile = toNubList v })+      ]+  . filterFields+      [ "doc-index-file"+      , "root-cmd", "symlink-bindir"+      , "build-log"+      , "remote-build-reporting", "report-planning-failure"+      , "one-shot", "jobs", "offline"+        -- solver flags:+      , "max-backjumps", "reorder-goals", "strong-flags"+      ]+  . commandOptionsToFields+  ) (installOptions ParseArgs)+  where+    constraintSrc = ConstraintSourceProjectConfig "TODO"++parseAllowNewer :: ReadP r AllowNewer+parseAllowNewer =+     ((const AllowNewerNone <$> (Parse.string "none" +++ Parse.string "None"))+  +++ (const AllowNewerAll  <$> (Parse.string "all"  +++ Parse.string "All")))+  <++ (      AllowNewerSome <$> parseOptCommaList parse)++dispAllowNewer :: AllowNewer -> Doc+dispAllowNewer  AllowNewerNone       = Disp.text "None"+dispAllowNewer (AllowNewerSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma+                                                 . map disp $ pkgs+dispAllowNewer  AllowNewerAll        = Disp.text "All"+++legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]+legacyPackageConfigFieldDescrs =+  ( liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+  . addFields+      [ newLineListField "extra-include-dirs"+          showTokenQ parseTokenQ+          configExtraIncludeDirs+          (\v conf -> conf { configExtraIncludeDirs = v })+      , newLineListField "extra-lib-dirs"+          showTokenQ parseTokenQ+          configExtraLibDirs+          (\v conf -> conf { configExtraLibDirs = v })+      , newLineListField "extra-framework-dirs"+          showTokenQ parseTokenQ+          configExtraFrameworkDirs+          (\v conf -> conf { configExtraFrameworkDirs = v })+      , newLineListField "extra-prog-path"+          showTokenQ parseTokenQ+          (fromNubList . configProgramPathExtra)+          (\v conf -> conf { configProgramPathExtra = toNubList v })+      , newLineListField "configure-options"+          showTokenQ parseTokenQ+          configConfigureArgs+          (\v conf -> conf { configConfigureArgs = v })+      , simpleField "flags"+          dispFlagAssignment parseFlagAssignment+          configConfigurationsFlags+          (\v conf -> conf { configConfigurationsFlags = v })+      ]+  . filterFields+      [ "compiler", "with-compiler", "with-hc-pkg"+      , "program-prefix", "program-suffix"+      , "library-vanilla", "library-profiling"+      , "shared", "executable-dynamic"+      , "profiling", "executable-profiling"+      , "profiling-detail", "library-profiling-detail"+      , "optimization", "debug-info", "library-for-ghci", "split-objs"+      , "executable-stripping", "library-stripping"+      , "tests", "benchmarks"+      , "coverage", "library-coverage"+      , "relocatable"+        -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"+        -- or "extra-prog-path". We use corrected ones above that parse+        -- as list fields.+      ]+  . commandOptionsToFields+  ) (configureOptions ParseArgs)+ +++    liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+    [ overrideFieldCompiler+    , overrideFieldOptimization+    , overrideFieldDebugInfo+    ]+ +++  ( liftFields+      legacyInstallPkgFlags+      (\flags conf -> conf { legacyInstallPkgFlags = flags })+  . filterFields+      [ "documentation", "run-tests"+      ]+  . commandOptionsToFields+  ) (installOptions ParseArgs)+ +++  ( liftFields+      legacyHaddockFlags+      (\flags conf -> conf { legacyHaddockFlags = flags })+  . mapFieldNames+      ("haddock-"++)+  . filterFields+      [ "hoogle", "html", "html-location"+      , "executables", "tests", "benchmarks", "all", "internal", "css"+      , "hyperlink-source", "hscolour-css"+      , "contents-location", "keep-temp-files"+      ]+  . commandOptionsToFields+  ) (haddockOptions ParseArgs)++  where+    overrideFieldCompiler =+      simpleField "compiler"+        (fromFlagOrDefault Disp.empty . fmap disp)+        (Parse.option mempty (fmap toFlag parse))+        configHcFlavor (\v flags -> flags { configHcFlavor = v })+++    -- TODO: [code cleanup] The following is a hack. The "optimization" and+    -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.+    -- Instead of a hand-written parser and printer, we should handle this case+    -- properly in the library.++    overrideFieldOptimization =+      liftField configOptimization+                (\v flags -> flags { configOptimization = v }) $+      let name = "optimization" in+      FieldDescr name+        (\f -> case f of+                 Flag NoOptimisation      -> Disp.text "False"+                 Flag NormalOptimisation  -> Disp.text "True"+                 Flag MaximumOptimisation -> Disp.text "2"+                 _                        -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)+           |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)+           |  str == "0"     -> ParseOk [] (Flag NoOptimisation)+           |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)+           |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")++    overrideFieldDebugInfo =+      liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $+      let name = "debug-info" in+      FieldDescr name+        (\f -> case f of+                 Flag NoDebugInfo      -> Disp.text "False"+                 Flag MinimalDebugInfo -> Disp.text "1"+                 Flag NormalDebugInfo  -> Disp.text "True"+                 Flag MaximalDebugInfo -> Disp.text "3"+                 _                     -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)+           |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)+           |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)+           |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")+++legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]+legacyPackageConfigSectionDescrs =+    [ packageRepoSectionDescr+    , packageSpecificOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programLocationsSectionDescr+    , liftSection+        legacySharedConfig+        (\flags conf -> conf { legacySharedConfig = flags }) $+      liftSection+        legacyGlobalFlags+        (\flags conf -> conf { legacyGlobalFlags = flags })+        remoteRepoSectionDescr+    ]++packageRepoSectionDescr :: SectionDescr LegacyProjectConfig+packageRepoSectionDescr =+    SectionDescr {+      sectionName        = "source-repository-package",+      sectionFields      = sourceRepoFieldDescrs,+      sectionSubsections = [],+      sectionGet         = map (\x->("", x))+                         . legacyPackagesRepo,+      sectionSet         =+        \lineno unused pkgrepo projconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'source-repository-package' takes no arguments"+          return projconf {+            legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]+          },+      sectionEmpty       = SourceRepo {+                             repoKind     = RepoThis, -- hopefully unused+                             repoType     = Nothing,+                             repoLocation = Nothing,+                             repoModule   = Nothing,+                             repoBranch   = Nothing,+                             repoTag      = Nothing,+                             repoSubdir   = Nothing+                           }+    }++packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig+packageSpecificOptionsSectionDescr =+    SectionDescr {+      sectionName        = "package",+      sectionFields      = legacyPackageConfigFieldDescrs+                        ++ programOptionsFieldDescrs+                             (configProgramArgs . legacyConfigureFlags)+                             (\args pkgconf -> pkgconf {+                                 legacyConfigureFlags = (legacyConfigureFlags pkgconf) {+                                   configProgramArgs  = args+                                 }+                               }+                             ),+      sectionSubsections = [],+      sectionGet         = \projconf ->+                             [ (display pkgname, pkgconf)+                             | (pkgname, pkgconf) <- Map.toList (legacySpecificConfig projconf) ],+      sectionSet         =+        \lineno pkgnamestr pkgconf projconf -> do+          pkgname <- case simpleParse pkgnamestr of+            Just pkgname -> return pkgname+            Nothing      -> syntaxError lineno $+                                "a 'package' section requires a package name "+                             ++ "as an argument"+          return projconf {+            legacySpecificConfig =+              Map.insertWith mappend pkgname pkgconf+                             (legacySpecificConfig projconf)+          },+      sectionEmpty       = mempty+    }++programOptionsFieldDescrs :: (a -> [(String, [String])])+                          -> ([(String, [String])] -> a -> a)+                          -> [FieldDescr a]+programOptionsFieldDescrs get set =+    commandOptionsToFields+  $ programConfigurationOptions+      defaultProgramDb+      ParseArgs get set++programOptionsSectionDescr :: SectionDescr LegacyPackageConfig+programOptionsSectionDescr =+    SectionDescr {+      sectionName        = "program-options",+      sectionFields      = programOptionsFieldDescrs+                             configProgramArgs+                             (\args conf -> conf { configProgramArgs = args }),+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-options' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }++programLocationsFieldDescrs :: [FieldDescr ConfigFlags]+programLocationsFieldDescrs =+     commandOptionsToFields+   $ programConfigurationPaths'+       (++ "-location")+       defaultProgramDb+       ParseArgs+       configProgramPaths+       (\paths conf -> conf { configProgramPaths = paths })++programLocationsSectionDescr :: SectionDescr LegacyPackageConfig+programLocationsSectionDescr =+    SectionDescr {+      sectionName        = "program-locations",+      sectionFields      = programLocationsFieldDescrs,+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-locations' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }+++-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- 'OptionField'.+programConfigurationOptions+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationOptions progConf showOrParseArgs get set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs  -> [programOptions  "PROG"]+    ParseArgs -> map (programOptions . programName . fst)+                 (knownPrograms progConf)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])+           (\progArgs -> [ joinsArgs args+                         | (prog', args) <- progArgs, prog==prog' ]))+++    joinsArgs = unwords . map escape+    escape arg | any isSpace arg = "\"" ++ arg ++ "\""+               | otherwise       = arg+++remoteRepoSectionDescr :: SectionDescr GlobalFlags+remoteRepoSectionDescr =+    SectionDescr {+      sectionName        = "repository",+      sectionFields      = remoteRepoFields,+      sectionSubsections = [],+      sectionGet         = map (\x->(remoteRepoName x, x)) . fromNubList+                         . globalRemoteRepos,+      sectionSet         =+        \lineno reponame repo0 conf -> do+          when (null reponame) $+            syntaxError lineno $ "a 'repository' section requires the "+                              ++ "repository name as an argument"+          let repo = repo0 { remoteRepoName = reponame }+          when (remoteRepoKeyThreshold repo+                 > length (remoteRepoRootKeys repo)) $+            warning $ "'key-threshold' for repository "+                   ++ show (remoteRepoName repo)+                   ++ " higher than number of keys"+          when (not (null (remoteRepoRootKeys repo))+                && remoteRepoSecure repo /= Just True) $+            warning $ "'root-keys' for repository "+                   ++ show (remoteRepoName repo)+                   ++ " non-empty, but 'secure' not set to True."+          return conf {+            globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)+          },+      sectionEmpty       = emptyRemoteRepo ""+    }+++-------------------------------+-- Local field utils+--++--TODO: [code cleanup] all these utils should move to Distribution.ParseUtils+-- either augmenting or replacing the ones there++--TODO: [code cleanup] this is a different definition from listField, like+-- commaNewLineListField it pretty prints on multiple lines+newLineListField :: String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+newLineListField = listFieldWithSep Disp.sep++--TODO: [code cleanup] local copy purely so we can use the fixed version+-- of parseOptCommaList below+listFieldWithSep :: ([Doc] -> Doc) -> String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldWithSep separator name showF readF get set =+  liftField get set' $+    ParseUtils.field name showF' (parseOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF++--TODO: [code cleanup] local redefinition that should replace the version in+-- D.ParseUtils. This version avoid parse ambiguity for list element parsers+-- that have multiple valid parses of prefixes.+parseOptCommaList :: ReadP r a -> ReadP r [a]+parseOptCommaList p = Parse.sepBy p sep+  where+    -- The separator must not be empty or it introduces ambiguity+    sep = (Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces)+      +++ (Parse.satisfy isSpace >> Parse.skipSpaces)++--TODO: [code cleanup] local redefinition that should replace the version in+-- D.ParseUtils called showFilePath. This version escapes "." and "--" which+-- otherwise are special syntax.+showTokenQ :: String -> Doc+showTokenQ ""            = Disp.empty+showTokenQ x@('-':'-':_) = Disp.text (show x)+showTokenQ x@('.':[])    = Disp.text (show x)+showTokenQ x             = showToken x++-- This is just a copy of parseTokenQ, using the fixed parseHaskellString+parseTokenQ :: ReadP r String+parseTokenQ = parseHaskellString+          <++ Parse.munch1 (\x -> not (isSpace x) && x /= ',')++--TODO: [code cleanup] use this to replace the parseHaskellString in+-- Distribution.ParseUtils. It turns out Read instance for String accepts+-- the ['a', 'b'] syntax, which we do not want. In particular it messes+-- up any token starting with [].+parseHaskellString :: ReadP r String+parseHaskellString =+  Parse.readS_to_P $+    Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0++-- Handy util+addFields :: [FieldDescr a]+          -> ([FieldDescr a] -> [FieldDescr a])+addFields = (++)
+ cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}++-- | Handling project configuration, types.+--+module Distribution.Client.ProjectConfig.Types (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    PackageConfig(..),++    -- * Resolving configuration+    SolverSettings(..),+    BuildTimeSettings(..),++  ) where++import Distribution.Client.Types+         ( RemoteRepo )+import Distribution.Client.Dependency.Types+         ( PreSolver, ConstraintSource )+import Distribution.Client.Targets+         ( UserConstraint )+import Distribution.Client.BuildReports.Types +         ( ReportLevel(..) )++import Distribution.Package+         ( PackageName, PackageId, UnitId, Dependency )+import Distribution.Version+         ( Version )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( FlagAssignment, SourceRepo(..) )+import Distribution.Simple.Compiler+         ( Compiler, CompilerFlavor+         , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )+import Distribution.Simple.Setup+         ( Flag, AllowNewer(..) )+import Distribution.Simple.InstallDirs+         ( PathTemplate )+import Distribution.Utils.NubList+         ( NubList )+import Distribution.Verbosity+         ( Verbosity )++import Data.Map (Map)+import Distribution.Compat.Binary (Binary)+import Distribution.Compat.Semigroup+import GHC.Generics (Generic)+++-------------------------------+-- Project config types+--++-- | This type corresponds directly to what can be written in the+-- @cabal.project@ file. Other sources of configuration can also be injected+-- into this type, such as the user-wide @~/.cabal/config@ file and the+-- command line of @cabal configure@ or @cabal build@.+--+-- Since it corresponds to the external project file it is an instance of+-- 'Monoid' and all the fields can be empty. This also means there has to+-- be a step where we resolve configuration. At a minimum resolving means+-- applying defaults but it can also mean merging information from multiple+-- sources. For example for package-specific configuration the project file+-- can specify configuration that applies to all local packages, and then+-- additional configuration for a specific package.+--+-- Future directions: multiple profiles, conditionals. If we add these+-- features then the gap between configuration as written in the config file+-- and resolved settings we actually use will become even bigger.+--+data ProjectConfig+   = ProjectConfig {++       -- | Packages in this project, including local dirs, local .cabal files+       -- local and remote tarballs. Where these are file globs, they must+       -- match something.+       projectPackages              :: [String],++       -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that+       -- file globs are allowed to match nothing. The primary use case for+       -- this is to be able to say @optional-packages: */@ to automagically+       -- pick up deps that we unpack locally.+       projectPackagesOptional      :: [String],++       -- | Packages in this project from remote source repositories.+       projectPackagesRepo          :: [SourceRepo],++       -- | Packages in this project from hackage repositories.+       projectPackagesNamed         :: [Dependency],++       projectConfigBuildOnly       :: ProjectConfigBuildOnly,+       projectConfigShared          :: ProjectConfigShared,+       projectConfigLocalPackages   :: PackageConfig,+       projectConfigSpecificPackage :: Map PackageName PackageConfig+     }+  deriving (Eq, Show, Generic)++-- | That part of the project configuration that only affects /how/ we build+-- and not the /value/ of the things we build. This means this information+-- does not need to be tracked for changes since it does not affect the+-- outcome.+--+data ProjectConfigBuildOnly+   = ProjectConfigBuildOnly {+       projectConfigVerbosity             :: Flag Verbosity,+       projectConfigDryRun                :: Flag Bool,+       projectConfigOnlyDeps              :: Flag Bool,+       projectConfigSummaryFile           :: NubList PathTemplate,+       projectConfigLogFile               :: Flag PathTemplate,+       projectConfigBuildReports          :: Flag ReportLevel,+       projectConfigReportPlanningFailure :: Flag Bool,+       projectConfigSymlinkBinDir         :: Flag FilePath,+       projectConfigOneShot               :: Flag Bool,+       projectConfigNumJobs               :: Flag (Maybe Int),+       projectConfigOfflineMode           :: Flag Bool,+       projectConfigKeepTempFiles         :: Flag Bool,+       projectConfigHttpTransport         :: Flag String,+       projectConfigIgnoreExpiry          :: Flag Bool,+       projectConfigCacheDir              :: Flag FilePath,+       projectConfigLogsDir               :: Flag FilePath,+       projectConfigWorldFile             :: Flag FilePath,+       projectConfigRootCmd               :: Flag String+     }+  deriving (Eq, Show, Generic)+++-- | Project configuration that is shared between all packages in the project.+-- In particular this includes configuration that affects the solver.+--+data ProjectConfigShared+   = ProjectConfigShared {+       projectConfigProgramPaths      :: Map String FilePath,+       projectConfigProgramArgs       :: Map String [String],+       projectConfigProgramPathExtra  :: NubList FilePath,+       projectConfigHcFlavor          :: Flag CompilerFlavor,+       projectConfigHcPath            :: Flag FilePath,+       projectConfigHcPkg             :: Flag FilePath,+       projectConfigHaddockIndex      :: Flag PathTemplate,++       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigUserInstall       :: Flag Bool,+     --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),+     --TODO: [required eventually] decide what to do with InstallDirs+     -- currently we don't allow it to be specified in the config file+     --projectConfigPackageDBs        :: [Maybe PackageDB],++       -- configuration used both by the solver and other phases+       projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.+       projectConfigLocalRepos        :: NubList FilePath,++       -- solver configuration+       projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],+       projectConfigPreferences       :: [Dependency],+       projectConfigFlagAssignment    :: FlagAssignment, --TODO: [required eventually] must be per-package, not global+       projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused+       projectConfigSolver            :: Flag PreSolver,+       projectConfigAllowNewer        :: Maybe AllowNewer,+       projectConfigMaxBackjumps      :: Flag Int,+       projectConfigReorderGoals      :: Flag Bool,+       projectConfigStrongFlags       :: Flag Bool++       -- More things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigIndependentGoals  :: Flag Bool,+     --projectConfigShadowPkgs        :: Flag Bool,+     --projectConfigReinstall         :: Flag Bool,+     --projectConfigAvoidReinstalls   :: Flag Bool,+     --projectConfigOverrideReinstall :: Flag Bool,+     --projectConfigUpgradeDeps       :: Flag Bool+     }+  deriving (Eq, Show, Generic)+++-- | Project configuration that is specific to each package, that is where we+-- can in principle have different values for different packages in the same+-- project.+--+data PackageConfig+   = PackageConfig {+       packageConfigVanillaLib          :: Flag Bool,+       packageConfigSharedLib           :: Flag Bool,+       packageConfigDynExe              :: Flag Bool,+       packageConfigProf                :: Flag Bool, --TODO: [code cleanup] sort out+       packageConfigProfLib             :: Flag Bool, --      this duplication+       packageConfigProfExe             :: Flag Bool, --      and consistency+       packageConfigProfDetail          :: Flag ProfDetailLevel,+       packageConfigProfLibDetail       :: Flag ProfDetailLevel,+       packageConfigConfigureArgs       :: [String],+       packageConfigOptimization        :: Flag OptimisationLevel,+       packageConfigProgPrefix          :: Flag PathTemplate,+       packageConfigProgSuffix          :: Flag PathTemplate,+       packageConfigExtraLibDirs        :: [FilePath],+       packageConfigExtraFrameworkDirs  :: [FilePath],+       packageConfigExtraIncludeDirs    :: [FilePath],+       packageConfigGHCiLib             :: Flag Bool,+       packageConfigSplitObjs           :: Flag Bool,+       packageConfigStripExes           :: Flag Bool,+       packageConfigStripLibs           :: Flag Bool,+       packageConfigTests               :: Flag Bool,+       packageConfigBenchmarks          :: Flag Bool,+       packageConfigCoverage            :: Flag Bool,+       packageConfigRelocatable         :: Flag Bool,+       packageConfigDebugInfo           :: Flag DebugInfoLevel,+       packageConfigRunTests            :: Flag Bool, --TODO: [required eventually] use this+       packageConfigDocumentation       :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHoogle       :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtml         :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this+       packageConfigHaddockExecutables  :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockTestSuites   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockInternal     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockCss          :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockHscolour     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHscolourCss  :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockContents     :: Flag PathTemplate --TODO: [required eventually] use this+     }+  deriving (Eq, Show, Generic)++instance Binary ProjectConfig+instance Binary ProjectConfigBuildOnly+instance Binary ProjectConfigShared+instance Binary PackageConfig+++instance Monoid ProjectConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfig where+  (<>) = gmappend+++instance Monoid ProjectConfigBuildOnly where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigBuildOnly where+  (<>) = gmappend+++instance Monoid ProjectConfigShared where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigShared where+  (<>) = gmappend+++instance Monoid PackageConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup PackageConfig where+  (<>) = gmappend++----------------------------------------+-- Resolving configuration to settings+--++-- | Resolved configuration for the solver. The idea is that this is easier to+-- use than the raw configuration because in the raw configuration everything+-- is optional (monoidial). In the 'BuildTimeSettings' every field is filled+-- in, if only with the defaults.+--+-- Use 'resolveSolverSettings' to make one from the project config (by+-- applying defaults etc).+--+data SolverSettings+   = SolverSettings {+       solverSettingRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+       solverSettingLocalRepos        :: [FilePath],+       solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],+       solverSettingPreferences       :: [Dependency],+       solverSettingFlagAssignment    :: FlagAssignment, --TODO: [required eventually] must be per-package, not global+       solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused+       solverSettingSolver            :: PreSolver,+       solverSettingAllowNewer        :: AllowNewer,+       solverSettingMaxBackjumps      :: Maybe Int,+       solverSettingReorderGoals      :: Bool,+       solverSettingStrongFlags       :: Bool+       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --solverSettingIndependentGoals  :: Bool,+     --solverSettingShadowPkgs        :: Bool,+     --solverSettingReinstall         :: Bool,+     --solverSettingAvoidReinstalls   :: Bool,+     --solverSettingOverrideReinstall :: Bool,+     --solverSettingUpgradeDeps       :: Bool+     }+  deriving (Eq, Show, Generic)++instance Binary SolverSettings+++-- | Resolved configuration for things that affect how we build and not the+-- value of the things we build. The idea is that this is easier to use than+-- the raw configuration because in the raw configuration everything is+-- optional (monoidial). In the 'BuildTimeSettings' every field is filled in,+-- if only with the defaults.+--+-- Use 'resolveBuildTimeSettings' to make one from the project config (by+-- applying defaults etc).+--+data BuildTimeSettings+   = BuildTimeSettings {+       buildSettingDryRun                :: Bool,+       buildSettingOnlyDeps              :: Bool,+       buildSettingSummaryFile           :: [PathTemplate],+       buildSettingLogFile               :: Maybe (Compiler  -> Platform+                                                -> PackageId -> UnitId+                                                             -> FilePath),+       buildSettingLogVerbosity          :: Verbosity,+       buildSettingBuildReports          :: ReportLevel,+       buildSettingReportPlanningFailure :: Bool,+       buildSettingSymlinkBinDir         :: [FilePath],+       buildSettingOneShot               :: Bool,+       buildSettingNumJobs               :: Int,+       buildSettingOfflineMode           :: Bool,+       buildSettingKeepTempFiles         :: Bool,+       buildSettingRemoteRepos           :: [RemoteRepo],+       buildSettingLocalRepos            :: [FilePath],+       buildSettingCacheDir              :: FilePath,+       buildSettingHttpTransport         :: Maybe String,+       buildSettingIgnoreExpiry          :: Bool,+       buildSettingRootCmd               :: Maybe String+     }+
+ cabal/cabal-install/Distribution/Client/ProjectPlanning.hs view
@@ -0,0 +1,2333 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns,+             DeriveGeneric, DeriveDataTypeable,+             RankNTypes, ScopedTypeVariables #-}++-- | Planning how to build everything in a project.+--+module Distribution.Client.ProjectPlanning (+    -- * elaborated install plan types+    ElaboratedInstallPlan,+    ElaboratedConfiguredPackage(..),+    ElaboratedPlanPackage,+    ElaboratedSharedConfig(..),+    ElaboratedReadyPackage,+    BuildStyle(..),+    CabalFileText,++    --TODO: [code cleanup] these types should live with execution, not with+    --      plan definition. Need to better separate InstallPlan definition.+    GenericBuildResult(..),+    BuildResult,+    BuildSuccess(..),+    BuildFailure(..),+    DocsResult(..),+    TestsResult(..),++    -- * Producing the elaborated install plan+    rebuildInstallPlan,++    -- * Build targets+    PackageTarget(..),+    ComponentTarget(..),+    SubComponentTarget(..),+    showComponentTarget,++    -- * Selecting a plan subset+    pruneInstallPlanToTargets,++    -- * Utils required for building+    pkgHasEphemeralBuildTargets,+    pkgBuildTargetWholeComponents,++    -- * Setup.hs CLI flags for building+    setupHsScriptOptions,+    setupHsConfigureFlags,+    setupHsBuildFlags,+    setupHsBuildArgs,+    setupHsReplFlags,+    setupHsReplArgs,+    setupHsCopyFlags,+    setupHsRegisterFlags,+    setupHsHaddockFlags,++    packageHashInputs,++    -- TODO: [code cleanup] utils that should live in some shared place?+    createPackageDBIfMissing+  ) where++import           Distribution.Client.PackageHash+import           Distribution.Client.RebuildMonad+import           Distribution.Client.ProjectConfig++import           Distribution.Client.Types hiding+  (BuildResult,BuildSuccess(..), BuildFailure(..), DocsResult(..)+  ,TestsResult(..))+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, InstallPlan, GenericPlanPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.Dependency+import           Distribution.Client.Dependency.Types+import qualified Distribution.Client.ComponentDeps as CD+import           Distribution.Client.ComponentDeps (ComponentDeps)+import qualified Distribution.Client.IndexUtils as IndexUtils+import qualified Distribution.Client.PackageIndex as SourcePackageIndex+import           Distribution.Client.Targets (userToPackageConstraint)+import           Distribution.Client.DistDirLayout+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+import           Distribution.Client.PkgConfigDb+import           Distribution.Client.Setup hiding (packageName, cabalVersion)+import           Distribution.Utils.NubList (toNubList)++import           Distribution.Package hiding+  (InstalledPackageId, installedPackageId)+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import qualified Distribution.PackageDescription as PD+import qualified Distribution.PackageDescription.Configuration as PD+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import           Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import           Distribution.Simple.Compiler hiding (Flag)+import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate+import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate+import           Distribution.Simple.Program+import           Distribution.Simple.Program.Db+import           Distribution.Simple.Program.Find+import qualified Distribution.Simple.Setup as Cabal+import           Distribution.Simple.Setup+  (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault)+import qualified Distribution.Simple.Configure as Cabal+import           Distribution.ModuleName (ModuleName)+import qualified Distribution.Simple.LocalBuildInfo as Cabal+import           Distribution.Simple.LocalBuildInfo (ComponentName(..))+import qualified Distribution.Simple.Register as Cabal+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Simple.InstallDirs (PathTemplate)+import qualified Distribution.Simple.BuildTarget as Cabal++import           Distribution.Simple.Utils hiding (matchFileGlob)+import           Distribution.Version+import           Distribution.Verbosity+import           Distribution.Text++import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Graph as Graph+import qualified Data.Tree  as Tree+import qualified Data.ByteString.Lazy as LBS++#if !MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif+import           Control.Monad+import           Control.Monad.State as State+import           Control.Exception+import           Data.List+import           Data.Maybe+import           Data.Monoid+import           Data.Function++import           Distribution.Compat.Binary+import           GHC.Generics (Generic)+import           Data.Typeable (Typeable)++import           System.FilePath+++------------------------------------------------------------------------------+-- * Elaborated install plan+------------------------------------------------------------------------------++-- "Elaborated" -- worked out with great care and nicety of detail;+--                 executed with great minuteness: elaborate preparations;+--                 elaborate care.+--+-- So here's the idea:+--+-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc+-- all passed in as separate args and which are then further selected,+-- transformed etc during the execution of the build. Instead we construct+-- an elaborated install plan that includes everything we will need, and then+-- during the execution of the plan we do as little transformation of this+-- info as possible.+--+-- So we're trying to split the work into two phases: construction of the+-- elaborated install plan (which as far as possible should be pure) and+-- then simple execution of that plan without any smarts, just doing what the+-- plan says to do.+--+-- So that means we need a representation of this fully elaborated install+-- plan. The representation consists of two parts:+--+-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a+--   representation of source packages that includes a lot more detail about+--   that package's individual configuration+--+-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for+--   every package in a plan. Rather than duplicate that info every entry in+--   the 'GenericInstallPlan' we keep that separately.+--+-- The division between the shared and per-package config is /not set in stone+-- for all time/. For example if we wanted to generalise the install plan to+-- describe a situation where we want to build some packages with GHC and some+-- with GHCJS then the platform and compiler would no longer be shared between+-- all packages but would have to be per-package (probably with some sanity+-- condition on the graph structure).+--++-- | The combination of an elaborated install plan plus a+-- 'ElaboratedSharedConfig' contains all the details necessary to be able+-- to execute the plan without having to make further policy decisions.+--+-- It does not include dynamic elements such as resources (such as http+-- connections).+--+type ElaboratedInstallPlan+   = GenericInstallPlan InstalledPackageInfo+                        ElaboratedConfiguredPackage+                        BuildSuccess BuildFailure++type ElaboratedPlanPackage+   = GenericPlanPackage InstalledPackageInfo+                        ElaboratedConfiguredPackage+                        BuildSuccess BuildFailure++type SolverInstallPlan+   = InstallPlan --TODO: [code cleanup] redefine locally or move def to solver interface++--TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle+--      even platform and compiler could be different if we're building things+--      like a server + client with ghc + ghcjs+data ElaboratedSharedConfig+   = ElaboratedSharedConfig {++       pkgConfigPlatform         :: Platform,+       pkgConfigCompiler         :: Compiler, --TODO: [code cleanup] replace with CompilerInfo+       pkgConfigProgramDb        :: ProgramDb --TODO: [code cleanup] no Eq instance+       --TODO: [code cleanup] binary instance does not preserve the prog paths+       --      perhaps should keep the configured progs separately+     }+  deriving (Show, Generic)++instance Binary ElaboratedSharedConfig++data ElaboratedConfiguredPackage+   = ElaboratedConfiguredPackage {++       pkgInstalledId :: InstalledPackageId,+       pkgSourceId    :: PackageId,++       -- | TODO: [code cleanup] we don't need this, just a few bits from it:+       --   build type, spec version+       pkgDescription :: Cabal.PackageDescription,++       -- | A total flag assignment for the package+       pkgFlagAssignment   :: Cabal.FlagAssignment,++       -- | The original default flag assignment, used only for reporting.+       pkgFlagDefaults     :: Cabal.FlagAssignment,++       -- | The exact dependencies (on other plan packages)+       --+       pkgDependencies     :: ComponentDeps [ConfiguredId],++       -- | Which optional stanzas (ie testsuites, benchmarks) can be built.+       -- This means the solver produced a plan that has them available.+       -- This doesn't necessary mean we build them by default.+       pkgStanzasAvailable :: Set OptionalStanza,++       -- | Which optional stanzas the user explicitly asked to enable or+       -- to disable. This tells us which ones we build by default, and+       -- helps with error messages when the user asks to build something+       -- they explicitly disabled.+       pkgStanzasRequested :: Map OptionalStanza Bool,++       -- | Which optional stanzas (ie testsuites, benchmarks) will actually+       -- be enabled during the package configure step.+       pkgStanzasEnabled :: Set OptionalStanza,++       -- | Where the package comes from, e.g. tarball, local dir etc. This+       --   is not the same as where it may be unpacked to for the build.+       pkgSourceLocation :: PackageLocation (Maybe FilePath),++       -- | The hash of the source, e.g. the tarball. We don't have this for+       -- local source dir packages.+       pkgSourceHash     :: Maybe PackageSourceHash,++       --pkgSourceDir ? -- currently passed in later because they can use temp locations+       --pkgBuildDir  ? -- but could in principle still have it here, with optional instr to use temp loc++       pkgBuildStyle             :: BuildStyle,++       pkgSetupPackageDBStack    :: PackageDBStack,+       pkgBuildPackageDBStack    :: PackageDBStack,+       pkgRegisterPackageDBStack :: PackageDBStack,++       -- | The package contains a library and so must be registered+       pkgRequiresRegistration :: Bool,+       pkgDescriptionOverride  :: Maybe CabalFileText,++       pkgVanillaLib           :: Bool,+       pkgSharedLib            :: Bool,+       pkgDynExe               :: Bool,+       pkgGHCiLib              :: Bool,+       pkgProfLib              :: Bool,+       pkgProfExe              :: Bool,+       pkgProfLibDetail        :: ProfDetailLevel,+       pkgProfExeDetail        :: ProfDetailLevel,+       pkgCoverage             :: Bool,+       pkgOptimization         :: OptimisationLevel,+       pkgSplitObjs            :: Bool,+       pkgStripLibs            :: Bool,+       pkgStripExes            :: Bool,+       pkgDebugInfo            :: DebugInfoLevel,++       pkgConfigureScriptArgs   :: [String],+       pkgExtraLibDirs          :: [FilePath],+       pkgExtraFrameworkDirs    :: [FilePath],+       pkgExtraIncludeDirs      :: [FilePath],+       pkgProgPrefix            :: Maybe PathTemplate,+       pkgProgSuffix            :: Maybe PathTemplate,++       pkgInstallDirs           :: InstallDirs.InstallDirs FilePath,++       pkgHaddockHoogle         :: Bool,+       pkgHaddockHtml           :: Bool,+       pkgHaddockHtmlLocation   :: Maybe String,+       pkgHaddockExecutables    :: Bool,+       pkgHaddockTestSuites     :: Bool,+       pkgHaddockBenchmarks     :: Bool,+       pkgHaddockInternal       :: Bool,+       pkgHaddockCss            :: Maybe FilePath,+       pkgHaddockHscolour       :: Bool,+       pkgHaddockHscolourCss    :: Maybe FilePath,+       pkgHaddockContents       :: Maybe PathTemplate,++       -- Setup.hs related things:++       -- | One of four modes for how we build and interact with the Setup.hs+       -- script, based on whether it's a build-type Custom, with or without+       -- explicit deps and the cabal spec version the .cabal file needs.+       pkgSetupScriptStyle      :: SetupScriptStyle,++       -- | The version of the Cabal command line interface that we are using+       -- for this package. This is typically the version of the Cabal lib+       -- that the Setup.hs is built against.+       pkgSetupScriptCliVersion :: Version,++       -- Build time related:+       pkgBuildTargets          :: [ComponentTarget],+       pkgReplTarget            :: Maybe ComponentTarget,+       pkgBuildHaddocks         :: Bool+     }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedConfiguredPackage++instance Package ElaboratedConfiguredPackage where+  packageId = pkgSourceId++instance HasUnitId ElaboratedConfiguredPackage where+  installedUnitId = pkgInstalledId++instance PackageFixedDeps ElaboratedConfiguredPackage where+  depends = fmap (map installedPackageId) . pkgDependencies++-- | This is used in the install plan to indicate how the package will be+-- built.+--+data BuildStyle =+    -- | The classic approach where the package is built, then the files+    -- installed into some location and the result registered in a package db.+    --+    -- If the package came from a tarball then it's built in a temp dir and+    -- the results discarded.+    BuildAndInstall++    -- | The package is built, but the files are not installed anywhere,+    -- rather the build dir is kept and the package is registered inplace.+    --+    -- Such packages can still subsequently be installed.+    --+    -- Typically 'BuildAndInstall' packages will only depend on other+    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.+    --+  | BuildInplaceOnly+  deriving (Eq, Show, Generic)++instance Binary BuildStyle++type CabalFileText = LBS.ByteString++type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage++--TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan+-- because the same ipkg is used by many packages. So the binary file will be big.+-- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo?+-- or transform to a shared form when serialising / deserialising++data GenericBuildResult ipkg iresult ifailure+                  = BuildFailure ifailure+                  | BuildSuccess (Maybe ipkg) iresult+  deriving (Eq, Show, Generic)++instance (Binary ipkg, Binary iresult, Binary ifailure) =>+         Binary (GenericBuildResult ipkg iresult ifailure)++type BuildResult  = GenericBuildResult InstalledPackageInfo+                                       BuildSuccess BuildFailure++data BuildSuccess = BuildOk DocsResult TestsResult+  deriving (Eq, Show, Generic)++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+  deriving (Eq, Show, Generic)++data TestsResult = TestsNotTried | TestsOk+  deriving (Eq, Show, Generic)++data BuildFailure = PlanningFailed              --TODO: [required eventually] not yet used+                  | DependentFailed PackageId+                  | DownloadFailed  String      --TODO: [required eventually] not yet used+                  | UnpackFailed    String      --TODO: [required eventually] not yet used+                  | ConfigureFailed String+                  | BuildFailed     String+                  | TestsFailed     String      --TODO: [required eventually] not yet used+                  | InstallFailed   String+  deriving (Eq, Show, Typeable, Generic)++instance Exception BuildFailure++instance Binary BuildFailure+instance Binary BuildSuccess+instance Binary DocsResult+instance Binary TestsResult+++sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig+                                       -> ElaboratedConfiguredPackage+                                       -> Bool+sanityCheckElaboratedConfiguredPackage sharedConfig+                                       pkg@ElaboratedConfiguredPackage{..} =++    pkgStanzasEnabled `Set.isSubsetOf` pkgStanzasAvailable++    -- the stanzas explicitly enabled should be available and enabled+ && Map.keysSet (Map.filter id pkgStanzasRequested)+      `Set.isSubsetOf` pkgStanzasEnabled++    -- the stanzas explicitly disabled should not be available+ && Set.null (Map.keysSet (Map.filter not pkgStanzasRequested)+                `Set.intersection` pkgStanzasAvailable)++ && (pkgBuildStyle == BuildInplaceOnly ||+     installedPackageId pkg == hashedInstalledPackageId+                                 (packageHashInputs sharedConfig pkg))++ && (pkgBuildStyle == BuildInplaceOnly ||+     Set.null pkgStanzasAvailable)+++------------------------------------------------------------------------------+-- * Deciding what to do: making an 'ElaboratedInstallPlan'+------------------------------------------------------------------------------++rebuildInstallPlan :: Verbosity+                   -> FilePath -> DistDirLayout -> CabalDirLayout+                   -> ProjectConfig+                   -> IO ( ElaboratedInstallPlan+                         , ElaboratedSharedConfig+                         , ProjectConfig )+rebuildInstallPlan verbosity+                   projectRootDir+                   distDirLayout@DistDirLayout {+                     distDirectory,+                     distProjectCacheFile,+                     distProjectCacheDirectory+                   }+                   cabalDirLayout@CabalDirLayout {+                     cabalPackageCacheDirectory,+                     cabalStoreDirectory,+                     cabalStorePackageDB+                   }+                   cliConfig =+    runRebuild $ do+    progsearchpath <- liftIO $ getSystemSearchPath+    let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }++    -- The overall improved plan is cached+    rerunIfChanged verbosity projectRootDir fileMonitorImprovedPlan+                   -- react to changes in command line args and the path+                   (cliConfigPersistent, progsearchpath) $ do++      -- And so is the elaborated plan that the improved plan based on+      (elaboratedPlan, elaboratedShared,+       projectConfig) <-+        rerunIfChanged verbosity projectRootDir fileMonitorElaboratedPlan+                       (cliConfigPersistent, progsearchpath) $ do++          (projectConfig, projectConfigTransient) <- phaseReadProjectConfig+          localPackages <- phaseReadLocalPackages projectConfig+          compilerEtc   <- phaseConfigureCompiler projectConfig+          solverPlan    <- phaseRunSolver         projectConfigTransient+                                                  compilerEtc localPackages+          (elaboratedPlan,+           elaboratedShared) <- phaseElaboratePlan projectConfigTransient+                                                   compilerEtc+                                                   solverPlan localPackages++          return (elaboratedPlan, elaboratedShared,+                  projectConfig)++      -- The improved plan changes each time we install something, whereas+      -- the underlying elaborated plan only changes when input config+      -- changes, so it's worth caching them separately.+      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared+      return (improvedPlan, elaboratedShared, projectConfig)++  where+    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"+    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"+    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"+    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"+    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"++    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b+    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile++    -- Read the cabal.project (or implicit config) and combine it with+    -- arguments from the command line+    --+    phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig)+    phaseReadProjectConfig = do+      liftIO $ do+        info verbosity "Project settings changed, reconfiguring..."+        createDirectoryIfMissingVerbose verbosity False distDirectory+        createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory++      projectConfig <- readProjectConfig verbosity projectRootDir++      -- The project config comming from the command line includes "build only"+      -- flags that we don't cache persistently (because like all "build only"+      -- flags they do not affect the value of the outcome) but that we do+      -- sometimes using during planning (in particular the http transport)+      let projectConfigTransient  = projectConfig <> cliConfig+          projectConfigPersistent = projectConfig+                                 <> cliConfig {+                                      projectConfigBuildOnly = mempty+                                    }+      liftIO $ writeProjectConfigFile (distProjectCacheFile "config")+                                      projectConfigPersistent+      return (projectConfigPersistent, projectConfigTransient)++    -- Look for all the cabal packages in the project+    -- some of which may be local src dirs, tarballs etc+    --+    phaseReadLocalPackages :: ProjectConfig+                           -> Rebuild [UnresolvedSourcePackage]+    phaseReadLocalPackages projectConfig = do++      localCabalFiles <- findProjectPackages projectRootDir projectConfig+      mapM (readSourcePackage verbosity) localCabalFiles+++    -- Configure the compiler we're using.+    --+    -- This is moderately expensive and doesn't change that often so we cache+    -- it independently.+    --+    phaseConfigureCompiler :: ProjectConfig+                           -> Rebuild (Compiler, Platform, ProgramDb)+    phaseConfigureCompiler ProjectConfig{projectConfigShared} = do+        progsearchpath <- liftIO $ getSystemSearchPath+        rerunIfChanged verbosity projectRootDir fileMonitorCompiler+                       (hcFlavor, hcPath, hcPkg, progsearchpath) $ do++          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."+          result@(_, _, progdb) <- liftIO $+            Cabal.configCompilerEx+              hcFlavor hcPath hcPkg+              defaultProgramDb verbosity++          monitorFiles (programsMonitorFiles progdb)++          return result+      where+        hcFlavor = flagToMaybe projectConfigHcFlavor+        hcPath   = flagToMaybe projectConfigHcPath+        hcPkg    = flagToMaybe projectConfigHcPkg+        ProjectConfigShared {+          projectConfigHcFlavor,+          projectConfigHcPath,+          projectConfigHcPkg+        }        = projectConfigShared+++    -- Run the solver to get the initial install plan.+    -- This is expensive so we cache it independently.+    --+    phaseRunSolver :: ProjectConfig+                   -> (Compiler, Platform, ProgramDb)+                   -> [UnresolvedSourcePackage]+                   -> Rebuild (SolverInstallPlan, PackagesImplicitSetupDeps)+    phaseRunSolver projectConfig@ProjectConfig {+                     projectConfigShared,+                     projectConfigBuildOnly+                   }+                   (compiler, platform, progdb)+                   localPackages =+        rerunIfChanged verbosity projectRootDir fileMonitorSolverPlan+                       (solverSettings, cabalPackageCacheDirectory,+                        localPackages, localPackagesEnabledStanzas,+                        compiler, platform, programsDbSignature progdb) $ do++          installedPkgIndex <- getInstalledPackages verbosity+                                                    compiler progdb platform+                                                    corePackageDbs+          sourcePkgDb       <- getSourcePackages    verbosity withRepoCtx+          pkgConfigDB       <- liftIO $+                               readPkgConfigDb      verbosity progdb++          liftIO $ do+            solver <- chooseSolver verbosity+                                   (solverSettingSolver solverSettings)+                                   (compilerInfo compiler)++            notice verbosity "Resolving dependencies..."+            foldProgress logMsg die return $+              planPackages compiler platform solver solverSettings+                           installedPkgIndex sourcePkgDb pkgConfigDB+                           localPackages localPackagesEnabledStanzas+      where+        corePackageDbs = [GlobalPackageDB]+        withRepoCtx    = projectConfigWithSolverRepoContext verbosity+                           cabalPackageCacheDirectory+                           projectConfigShared+                           projectConfigBuildOnly+        solverSettings = resolveSolverSettings projectConfigShared+        logMsg message rest = debugNoWrap verbosity message >> rest++        localPackagesEnabledStanzas =+          Map.fromList+            [ (pkgname, stanzas)+            | pkg <- localPackages+            , let pkgname            = packageName pkg+                  testsEnabled       = lookupLocalPackageConfig+                                         packageConfigTests+                                         projectConfig pkgname+                  benchmarksEnabled  = lookupLocalPackageConfig+                                         packageConfigBenchmarks+                                         projectConfig pkgname+                  stanzas =+                    Map.fromList $+                      [ (TestStanzas, enabled)+                      | enabled <- flagToList testsEnabled ]+                   ++ [ (BenchStanzas , enabled)+                      | enabled <- flagToList benchmarksEnabled ]+            ]++    -- Elaborate the solver's install plan to get a fully detailed plan. This+    -- version of the plan has the final nix-style hashed ids.+    --+    phaseElaboratePlan :: ProjectConfig+                       -> (Compiler, Platform, ProgramDb)+                       -> (SolverInstallPlan, PackagesImplicitSetupDeps)+                       -> [SourcePackage loc]+                       -> Rebuild ( ElaboratedInstallPlan+                                  , ElaboratedSharedConfig )+    phaseElaboratePlan ProjectConfig {+                         projectConfigShared,+                         projectConfigLocalPackages,+                         projectConfigSpecificPackage,+                         projectConfigBuildOnly+                       }+                       (compiler, platform, progdb)+                       (solverPlan, pkgsImplicitSetupDeps)+                       localPackages = do++        liftIO $ debug verbosity "Elaborating the install plan..."++        sourcePackageHashes <-+          rerunIfChanged verbosity projectRootDir fileMonitorSourceHashes+                         (map packageId $ InstallPlan.toList solverPlan) $+            getPackageSourceHashes verbosity withRepoCtx solverPlan++        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler+        return $+          elaborateInstallPlan+            platform compiler progdb+            distDirLayout+            cabalDirLayout+            solverPlan+            pkgsImplicitSetupDeps+            localPackages+            sourcePackageHashes+            defaultInstallDirs+            projectConfigShared+            projectConfigLocalPackages+            projectConfigSpecificPackage+      where+        withRepoCtx = projectConfigWithSolverRepoContext verbosity+                        cabalPackageCacheDirectory+                        projectConfigShared+                        projectConfigBuildOnly+++    -- Improve the elaborated install plan. The elaborated plan consists+    -- mostly of source packages (with full nix-style hashed ids). Where+    -- corresponding installed packages already exist in the store, replace+    -- them in the plan.+    --+    -- Note that we do monitor the store's package db here, so we will redo+    -- this improvement phase when the db changes -- including as a result of+    -- executing a plan and installing things.+    --+    phaseImprovePlan :: ElaboratedInstallPlan+                     -> ElaboratedSharedConfig+                     -> Rebuild ElaboratedInstallPlan+    phaseImprovePlan elaboratedPlan elaboratedShared = do++        liftIO $ debug verbosity "Improving the install plan..."+        recreateDirectory verbosity True storeDirectory+        storePkgIndex <- getPackageDBContents verbosity+                                              compiler progdb platform+                                              storePackageDb+        let improvedPlan = improveInstallPlanWithPreExistingPackages+                             storePkgIndex+                             elaboratedPlan+        return improvedPlan++      where+        storeDirectory  = cabalStoreDirectory (compilerId compiler)+        storePackageDb  = cabalStorePackageDB (compilerId compiler)+        ElaboratedSharedConfig {+          pkgConfigCompiler  = compiler,+          pkgConfigPlatform  = platform,+          pkgConfigProgramDb = progdb+        } = elaboratedShared+++programsMonitorFiles :: ProgramDb -> [MonitorFilePath]+programsMonitorFiles progdb =+    [ monitor+    | prog    <- configuredPrograms progdb+    , monitor <- monitorFileSearchPath (programMonitorFiles prog)+                                       (programPath prog)+    ]++-- | Select the bits of a 'ProgramDb' to monitor for value changes.+-- Use 'programsMonitorFiles' for the files to monitor.+--+programsDbSignature :: ProgramDb -> [ConfiguredProgram]+programsDbSignature progdb =+    [ prog { programMonitorFiles = []+           , programOverrideEnv  = filter ((/="PATH") . fst)+                                          (programOverrideEnv prog) }+    | prog <- configuredPrograms progdb ]++getInstalledPackages :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDBStack+                     -> Rebuild InstalledPackageIndex+getInstalledPackages verbosity compiler progdb platform packagedbs = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    packagedbs progdb platform)+    liftIO $ IndexUtils.getInstalledPackages+               verbosity compiler+               packagedbs progdb++getPackageDBContents :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDB+                     -> Rebuild InstalledPackageIndex+getPackageDBContents verbosity compiler progdb platform packagedb = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    [packagedb] progdb platform)+    liftIO $ do+      createPackageDBIfMissing verbosity compiler+                               progdb [packagedb]+      Cabal.getPackageDBContents verbosity compiler+                                 packagedb progdb++getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)+                  -> Rebuild SourcePackageDb+getSourcePackages verbosity withRepoCtx = do+    (sourcePkgDb, repos) <-+      liftIO $+        withRepoCtx $ \repoctx -> do+          sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx+          return (sourcePkgDb, repoContextRepos repoctx)++    monitorFiles . map monitorFile+                 . IndexUtils.getSourcePackagesMonitorFiles+                 $ repos+    return sourcePkgDb++createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb+                         -> PackageDBStack -> IO ()+createPackageDBIfMissing verbosity compiler progdb packageDbs =+  case reverse packageDbs of+    SpecificPackageDB dbPath : _ -> do+      exists <- liftIO $ Cabal.doesPackageDBExist dbPath+      unless exists $ do+        createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath)+        Cabal.createPackageDB verbosity compiler progdb False dbPath+    _ -> return ()+++recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()+recreateDirectory verbosity createParents dir = do+    liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir+    monitorFiles [monitorDirectoryExistence dir]+++-- | Get the 'HashValue' for all the source packages where we use hashes,+-- and download any packages required to do so.+--+-- Note that we don't get hashes for local unpacked packages.+--+getPackageSourceHashes :: Verbosity+                       -> (forall a. (RepoContext -> IO a) -> IO a)+                       -> SolverInstallPlan+                       -> Rebuild (Map PackageId PackageSourceHash)+getPackageSourceHashes verbosity withRepoCtx installPlan = do++    -- Determine which packages need fetching, and which are present already+    --+    pkgslocs <- liftIO $ sequence+      [ do let locm = packageSource pkg+           mloc <- checkFetched locm+           return (pkg, locm, mloc)+      | InstallPlan.Configured+          (ConfiguredPackage pkg _ _ _) <- InstallPlan.toList installPlan ]++    let requireDownloading = [ (pkg, locm) | (pkg, locm, Nothing) <- pkgslocs ]+        alreadyDownloaded  = [ (pkg, loc)  | (pkg, _, Just loc)   <- pkgslocs ]++    -- Download the ones we need+    --+    newlyDownloaded <-+      if null requireDownloading+        then return []+        else liftIO $+              withRepoCtx $ \repoctx ->+                sequence+                  [ do loc <- fetchPackage verbosity repoctx locm+                       return (pkg, loc)+                  | (pkg, locm) <- requireDownloading ]++    -- Get the hashes of all the tarball packages (i.e. not local dir pkgs)+    --+    let pkgsTarballs =+          [ (packageId pkg, tarball)+          | (pkg, srcloc) <- newlyDownloaded ++ alreadyDownloaded+          , tarball <- maybeToList (tarballFileLocation srcloc) ]++    monitorFiles [ monitorFile tarball | (_pkgid, tarball) <- pkgsTarballs ]++    liftM Map.fromList $ liftIO $+      sequence+        [ do srchash <- readFileHashValue tarball+             return (pkgid, srchash)+        | (pkgid, tarball) <- pkgsTarballs ]+  where+    tarballFileLocation (LocalUnpackedPackage _dir)      = Nothing+    tarballFileLocation (LocalTarballPackage    tarball) = Just tarball+    tarballFileLocation (RemoteTarballPackage _ tarball) = Just tarball+    tarballFileLocation (RepoTarballPackage _ _ tarball) = Just tarball+++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Compiler+             -> Platform+             -> Solver -> SolverSettings+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [UnresolvedSourcePackage]+             -> Map PackageName (Map OptionalStanza Bool)+             -> Progress String String+                         (SolverInstallPlan, PackagesImplicitSetupDeps)+planPackages comp platform solver SolverSettings{..}+             installedPkgIndex sourcePkgDb pkgConfigDB+             localPackages pkgStanzasEnable =++    rememberImplicitSetupDeps (depResolverSourcePkgIndex stdResolverParams) <$>++    resolveDependencies+      platform (compilerInfo comp)+      pkgConfigDB solver+      resolverParams++  where++    --TODO: [nice to have] disable multiple instances restriction in the solver, but then+    -- make sure we can cope with that in the output.+    resolverParams =++        setMaxBackjumps solverSettingMaxBackjumps++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setIndependentGoals solverSettingIndependentGoals++      . setReorderGoals solverSettingReorderGoals++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setAvoidReinstalls solverSettingAvoidReinstalls++        --TODO: [required eventually] should only be configurable for custom installs+   -- . setShadowPkgs solverSettingShadowPkgs++      . setStrongFlags solverSettingStrongFlags++        --TODO: [required eventually] decide if we need to prefer installed for+        -- global packages, or prefer latest even for global packages. Perhaps+        -- should be configurable but with a different name than "upgrade-dependencies".+      . setPreferenceDefault PreferLatestForSelected+                           {-(if solverSettingUpgradeDeps+                                then PreferAllLatest+                                else PreferLatestForSelected)-}++      . removeUpperBounds solverSettingAllowNewer++      . addDefaultSetupDependencies (defaultSetupDeps platform+                                   . PD.packageDescription+                                   . packageDescription)++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | Dependency name ver <- solverSettingPreferences ]++      . addConstraints+          -- version constraints from the config file or command line+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- solverSettingConstraints ]++      . addPreferences+          -- enable stanza preference where the user did not specify+          [ PackageStanzasPreference pkgname stanzas+          | pkg <- localPackages+          , let pkgname = packageName pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Nothing ]+          , not (null stanzas)+          ]++      . addConstraints+          -- enable stanza constraints where the user asked to enable+          [ LabeledPackageConstraint+              (PackageConstraintStanzas pkgname stanzas)+              ConstraintSourceConfigFlagOrTarget+          | pkg <- localPackages+          , let pkgname = packageName pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Just True ]+          , not (null stanzas)+          ]++      . addConstraints+          --TODO: [nice to have] this just applies all flags to all targets which+          -- is silly. We should check if the flags are appropriate+          [ LabeledPackageConstraint+              (PackageConstraintFlags pkgname flags)+              ConstraintSourceConfigFlagOrTarget+          | let flags = solverSettingFlagAssignment+          , not (null flags)+          , pkg <- localPackages+          , let pkgname = packageName pkg ]++      $ stdResolverParams++    stdResolverParams =+      standardInstallPolicy+        installedPkgIndex sourcePkgDb+        (map SpecificSourcePackage localPackages)+++------------------------------------------------------------------------------+-- * Install plan post-processing+------------------------------------------------------------------------------++-- This phase goes from the InstallPlan we get from the solver and has to+-- make an elaborated install plan.+--+-- We go in two steps:+--+--  1. elaborate all the source packages that the solver has chosen.+--  2. swap source packages for pre-existing installed packages wherever+--     possible.+--+-- We do it in this order, elaborating and then replacing, because the easiest+-- way to calculate the installed package ids used for the replacement step is+-- from the elaborated configuration for each package.+++++------------------------------------------------------------------------------+-- * Install plan elaboration+------------------------------------------------------------------------------++-- | Produce an elaborated install plan using the policy for local builds with+-- a nix-style shared store.+--+-- In theory should be able to make an elaborated install plan with a policy+-- matching that of the classic @cabal install --user@ or @--global@+--+elaborateInstallPlan+  :: Platform -> Compiler -> ProgramDb+  -> DistDirLayout+  -> CabalDirLayout+  -> SolverInstallPlan+  -> PackagesImplicitSetupDeps+  -> [SourcePackage loc]+  -> Map PackageId PackageSourceHash+  -> InstallDirs.InstallDirTemplates+  -> ProjectConfigShared+  -> PackageConfig+  -> Map PackageName PackageConfig+  -> (ElaboratedInstallPlan, ElaboratedSharedConfig)+elaborateInstallPlan platform compiler progdb+                     DistDirLayout{..}+                     cabalDirLayout@CabalDirLayout{cabalStorePackageDB}+                     solverPlan pkgsImplicitSetupDeps localPackages+                     sourcePackageHashes+                     defaultInstallDirs+                     _sharedPackageConfig+                     localPackagesConfig+                     perPackageConfig =+    (elaboratedInstallPlan, elaboratedSharedConfig)+  where+    elaboratedSharedConfig =+      ElaboratedSharedConfig {+        pkgConfigPlatform         = platform,+        pkgConfigCompiler         = compiler,+        pkgConfigProgramDb        = progdb+      }++    elaboratedInstallPlan =+      flip InstallPlan.mapPreservingGraph solverPlan $ \mapDep planpkg ->+        case planpkg of+          InstallPlan.PreExisting pkg ->+            InstallPlan.PreExisting pkg++          InstallPlan.Configured  pkg ->+            InstallPlan.Configured+              (elaborateConfiguredPackage (fixupDependencies mapDep pkg))++          _ -> error "elaborateInstallPlan: unexpected package state"++    -- remap the installed package ids of the direct deps, since we're+    -- changing the installed package ids of all the packages to use the+    -- final nix-style hashed ids.+    fixupDependencies mapDep+       (ConfiguredPackage pkg flags stanzas deps) =+        ConfiguredPackage pkg flags stanzas deps'+      where+        deps' = fmap (map (\d -> d { confInstId = mapDep (confInstId d) })) deps++    elaborateConfiguredPackage :: ConfiguredPackage UnresolvedPkgLoc+                               -> ElaboratedConfiguredPackage+    elaborateConfiguredPackage+        pkg@(ConfiguredPackage (SourcePackage pkgid gdesc srcloc descOverride)+                               flags stanzas deps) =+        elaboratedPackage+      where+        -- Knot tying: the final elaboratedPackage includes the+        -- pkgInstalledId, which is calculated by hashing many+        -- of the other fields of the elaboratedPackage.+        --+        elaboratedPackage = ElaboratedConfiguredPackage {..}++        pkgInstalledId+          | shouldBuildInplaceOnly pkg+          = mkUnitId (display pkgid ++ "-inplace")++          | otherwise+          = assert (isJust pkgSourceHash) $+            hashedInstalledPackageId+              (packageHashInputs+                elaboratedSharedConfig+                elaboratedPackage)  -- recursive use of elaboratedPackage++          | otherwise+          = error $ "elaborateInstallPlan: non-inplace package "+                 ++ " is missing a source hash: " ++ display pkgid++        -- All the other fields of the ElaboratedConfiguredPackage+        --+        pkgSourceId         = pkgid+        pkgDescription      = let Right (desc, _) =+                                    PD.finalizePackageDescription+                                    flags (const True)+                                    platform (compilerInfo compiler)+                                    [] gdesc+                               in desc+        pkgFlagAssignment   = flags+        pkgFlagDefaults     = [ (Cabal.flagName flag, Cabal.flagDefault flag)+                              | flag <- PD.genPackageFlags gdesc ]+        pkgDependencies     = deps+        pkgStanzasAvailable = Set.fromList stanzas+        pkgStanzasRequested =+            Map.fromList $ [ (TestStanzas,  v) | v <- maybeToList tests ]+                        ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks ]+          where+            tests, benchmarks :: Maybe Bool+            tests      = perPkgOptionMaybe pkgid packageConfigTests+            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks++        -- These sometimes get adjusted later+        pkgStanzasEnabled   = Set.empty+        pkgBuildTargets     = []+        pkgReplTarget       = Nothing+        pkgBuildHaddocks    = False++        pkgSourceLocation   = srcloc+        pkgSourceHash       = Map.lookup pkgid sourcePackageHashes+        pkgBuildStyle       = if shouldBuildInplaceOnly pkg+                                then BuildInplaceOnly else BuildAndInstall+        pkgBuildPackageDBStack    = buildAndRegisterDbs+        pkgRegisterPackageDBStack = buildAndRegisterDbs+        pkgRequiresRegistration   = PD.hasPublicLib (PD.packageDescription gdesc)++        pkgSetupScriptStyle       = packageSetupScriptStylePostSolver+                                      pkgsImplicitSetupDeps pkg pkgDescription+        pkgSetupScriptCliVersion  = packageSetupScriptSpecVersion+                                      pkgSetupScriptStyle pkgDescription deps+        pkgSetupPackageDBStack    = buildAndRegisterDbs++        buildAndRegisterDbs+          | shouldBuildInplaceOnly pkg = inplacePackageDbs+          | otherwise                  = storePackageDbs++        pkgDescriptionOverride    = descOverride++        pkgVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively+        pkgSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary+        pkgDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe+        pkgGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still++        pkgProfExe       = perPkgOptionFlag pkgid False packageConfigProf+        pkgProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary++        (pkgProfExeDetail,+         pkgProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault+                               packageConfigProfDetail+                               packageConfigProfLibDetail+        pkgCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage++        pkgOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization+        pkgSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs+        pkgStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs+        pkgStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes+        pkgDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo++        pkgConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs+        pkgExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs+        pkgExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs+        pkgExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs+        pkgProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix+        pkgProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix++        pkgInstallDirs+          | shouldBuildInplaceOnly pkg+          -- use the ordinary default install dirs+          = (InstallDirs.absoluteInstallDirs+               pkgid+               (installedUnitId pkg)+               (compilerInfo compiler)+               InstallDirs.NoCopyDest+               platform+               defaultInstallDirs) {++              InstallDirs.libsubdir  = "", -- absoluteInstallDirs sets these as+              InstallDirs.datasubdir = ""  -- 'undefined' but we have to use+            }                              -- them as "Setup.hs configure" args++          | otherwise+          -- use special simplified install dirs+          = storePackageInstallDirs+              cabalDirLayout+              (compilerId compiler)+              pkgInstalledId++        pkgHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle+        pkgHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml+        pkgHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation+        pkgHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables+        pkgHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites+        pkgHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks+        pkgHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal+        pkgHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss+        pkgHaddockHscolour     = perPkgOptionFlag pkgid False packageConfigHaddockHscolour+        pkgHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss+        pkgHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents++    perPkgOptionFlag  :: PackageId -> a ->  (PackageConfig -> Flag a) -> a+    perPkgOptionMaybe :: PackageId ->       (PackageConfig -> Flag a) -> Maybe a+    perPkgOptionList  :: PackageId ->       (PackageConfig -> [a])    -> [a]++    perPkgOptionFlag  pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)+    perPkgOptionMaybe pkgid     f = flagToMaybe (lookupPerPkgOption pkgid f)+    perPkgOptionList  pkgid     f = lookupPerPkgOption pkgid f++    perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)+      where+        exe = fromFlagOrDefault def bothflag+        lib = fromFlagOrDefault def (bothflag <> libflag)++        bothflag = lookupPerPkgOption pkgid fboth+        libflag  = lookupPerPkgOption pkgid flib++    lookupPerPkgOption :: (Package pkg, Monoid m)+                       => pkg -> (PackageConfig -> m) -> m+    lookupPerPkgOption pkg f+      -- the project config specifies values that apply to packages local to+      -- but by default non-local packages get all default config values+      -- the project, and can specify per-package values for any package,+      | isLocalToProject pkg = local <> perpkg+      | otherwise            =          perpkg+      where+        local  = f localPackagesConfig+        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)++    inplacePackageDbs = storePackageDbs+                     ++ [ distPackageDB (compilerId compiler) ]++    storePackageDbs   = [ GlobalPackageDB+                        , cabalStorePackageDB (compilerId compiler) ]++    -- For this local build policy, every package that lives in a local source+    -- dir (as opposed to a tarball), or depends on such a package, will be+    -- built inplace into a shared dist dir. Tarball packages that depend on+    -- source dir packages will also get unpacked locally.+    shouldBuildInplaceOnly :: HasUnitId pkg => pkg -> Bool+    shouldBuildInplaceOnly pkg = Set.member (installedPackageId pkg)+                                            pkgsToBuildInplaceOnly++    pkgsToBuildInplaceOnly :: Set InstalledPackageId+    pkgsToBuildInplaceOnly =+        Set.fromList+      $ map installedPackageId+      $ InstallPlan.reverseDependencyClosure+          solverPlan+          [ fakeUnitId (packageId pkg)+          | pkg <- localPackages ]++    isLocalToProject :: Package pkg => pkg -> Bool+    isLocalToProject pkg = Set.member (packageId pkg)+                                      pkgsLocalToProject++    pkgsLocalToProject :: Set PackageId+    pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ]++    pkgsUseSharedLibrary :: Set PackageId+    pkgsUseSharedLibrary =+        packagesWithDownwardClosedProperty needsSharedLib+      where+        needsSharedLib pkg =+            fromMaybe compilerShouldUseSharedLibByDefault+                      (liftM2 (||) pkgSharedLib pkgDynExe)+          where+            pkgid        = packageId pkg+            pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib+            pkgDynExe    = perPkgOptionMaybe pkgid packageConfigDynExe++    --TODO: [code cleanup] move this into the Cabal lib. It's currently open+    -- coded in Distribution.Simple.Configure, but should be made a proper+    -- function of the Compiler or CompilerInfo.+    compilerShouldUseSharedLibByDefault =+      case compilerFlavor compiler of+        GHC   -> GHC.isDynamic compiler+        GHCJS -> GHCJS.isDynamic compiler+        _     -> False++    pkgsUseProfilingLibrary :: Set PackageId+    pkgsUseProfilingLibrary =+        packagesWithDownwardClosedProperty needsProfilingLib+      where+        needsProfilingLib pkg =+            fromFlagOrDefault False (profBothFlag <> profLibFlag)+          where+            pkgid        = packageId pkg+            profBothFlag = lookupPerPkgOption pkgid packageConfigProf+            profLibFlag  = lookupPerPkgOption pkgid packageConfigProfLib+            --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe++    packagesWithDownwardClosedProperty property =+        Set.fromList+      $ map packageId+      $ InstallPlan.dependencyClosure+          solverPlan+          [ installedPackageId pkg+          | pkg <- InstallPlan.toList solverPlan+          , property pkg ] -- just the packages that satisfy the propety+      --TODO: [nice to have] this does not check the config consistency,+      -- e.g. a package explicitly turning off profiling, but something+      -- depending on it that needs profiling. This really needs a separate+      -- package config validation/resolution pass.++      --TODO: [nice to have] config consistency checking:+      -- * profiling libs & exes, exe needs lib, recursive+      -- * shared libs & exes, exe needs lib, recursive+      -- * vanilla libs & exes, exe needs lib, recursive+      -- * ghci or shared lib needed by TH, recursive, ghc version dependent+++---------------------------+-- Build targets+--++-- | The various targets within a package. This is more of a high level+-- specification than a elaborated prescription.+--+data PackageTarget =+     -- | Build the default components in this package. This usually means+     -- just the lib and exes, but it can also mean the testsuites and+     -- benchmarks if the user explicitly requested them.+     BuildDefaultComponents+     -- | Build a specific component in this package.+   | BuildSpecificComponent ComponentTarget+   | ReplDefaultComponent+   | ReplSpecificComponent  ComponentTarget+   | HaddockDefaultComponents+  deriving (Eq, Show, Generic)++data ComponentTarget = ComponentTarget ComponentName SubComponentTarget+  deriving (Eq, Show, Generic)++data SubComponentTarget = WholeComponent+                        | ModuleTarget ModuleName+                        | FileTarget   FilePath+  deriving (Eq, Show, Generic)++instance Binary PackageTarget+instance Binary ComponentTarget+instance Binary SubComponentTarget+++--TODO: this needs to report some user target/config errors+elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget]+                        -> ([ComponentTarget], Maybe ComponentTarget, Bool)+elaboratePackageTargets ElaboratedConfiguredPackage{..} targets =+    let buildTargets  = nubComponentTargets+                      . map compatSubComponentTargets+                      . concatMap elaborateBuildTarget+                      $ targets+        --TODO: instead of listToMaybe we should be reporting an error here+        replTargets   = listToMaybe+                      . nubComponentTargets+                      . map compatSubComponentTargets+                      . concatMap elaborateReplTarget+                      $ targets+        buildHaddocks = HaddockDefaultComponents `elem` targets++     in (buildTargets, replTargets, buildHaddocks)+  where+    --TODO: need to report an error here if defaultComponents is empty+    elaborateBuildTarget  BuildDefaultComponents    = pkgDefaultComponents+    elaborateBuildTarget (BuildSpecificComponent t) = [t]+    elaborateBuildTarget  _                         = []++    --TODO: need to report an error here if defaultComponents is empty+    elaborateReplTarget  ReplDefaultComponent     = take 1 pkgDefaultComponents+    elaborateReplTarget (ReplSpecificComponent t) = [t]+    elaborateReplTarget  _                        = []++    pkgDefaultComponents =+        [ ComponentTarget cname WholeComponent+        | c <- Cabal.pkgComponents pkgDescription+        , PD.buildable (Cabal.componentBuildInfo c)+        , let cname = Cabal.componentName c+        , enabledOptionalStanza cname+        ]+      where+        enabledOptionalStanza cname =+          case componentOptionalStanza cname of+            Nothing     -> True+            Just stanza -> Map.lookup stanza pkgStanzasRequested+                        == Just True++    -- Not all Cabal Setup.hs versions support sub-component targets, so switch+    -- them over to the whole component+    compatSubComponentTargets :: ComponentTarget -> ComponentTarget+    compatSubComponentTargets target@(ComponentTarget cname _subtarget)+      | not setupHsSupportsSubComponentTargets+                  = ComponentTarget cname WholeComponent+      | otherwise = target++    -- Actually the reality is that no current version of Cabal's Setup.hs+    -- build command actually support building specific files or modules.+    setupHsSupportsSubComponentTargets = False+    -- TODO: when that changes, adjust this test, e.g.+    -- | pkgSetupScriptCliVersion >= Version [x,y] []++    nubComponentTargets :: [ComponentTarget] -> [ComponentTarget]+    nubComponentTargets =+        concatMap (wholeComponentOverrides . map snd)+      . groupBy ((==)    `on` fst)+      . sortBy  (compare `on` fst)+      . map (\t@(ComponentTarget cname _) -> (cname, t))++    -- If we're building the whole component then that the only target all we+    -- need, otherwise we can have several targets within the component.+    wholeComponentOverrides :: [ComponentTarget] -> [ComponentTarget]+    wholeComponentOverrides ts =+      case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of+        (t:_) -> [t]+        []    -> ts+++pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool+pkgHasEphemeralBuildTargets pkg =+    isJust (pkgReplTarget pkg)+ || (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg+                      , subtarget /= WholeComponent ]++-- | The components that we'll build all of, meaning that after they're built+-- we can skip building them again (unlike with building just some modules or+-- other files within a component).+--+pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage+                              -> Set ComponentName+pkgBuildTargetWholeComponents pkg =+    Set.fromList+      [ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ]+++------------------------------------------------------------------------------+-- * Install plan pruning+------------------------------------------------------------------------------++-- | Given a set of package targets (and optionally component targets within+-- those packages), take the subset of the install plan needed to build those+-- targets. Also, update the package config to specify which optional stanzas+-- to enable, and which targets within each package to build.+--+pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget]+                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan+pruneInstallPlanToTargets perPkgTargetsMap =+    either (\_ -> assert False undefined) id+  . InstallPlan.new False+  . PackageIndex.fromList+    -- We have to do this in two passes+  . pruneInstallPlanPass2+  . pruneInstallPlanPass1 perPkgTargetsMap+  . InstallPlan.toList++-- The first pass does three things:+--+-- * Set the build targets based on the user targets (but not rev deps yet).+-- * A first go at determining which optional stanzas (testsuites, benchmarks)+--   are needed. We have a second go in the next pass.+-- * Take the dependency closure using pruned dependencies. We prune deps that+--   are used only by unneeded optional stanzas. These pruned deps are only+--   used for the dependency closure and are not persisted in this pass.+--+pruneInstallPlanPass1 :: Map InstalledPackageId [PackageTarget]+                      -> [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass1 perPkgTargetsMap pkgs =+    map fst $+    dependencyClosure+      (installedPackageId . fst)  -- the pkg id+      snd                         -- the pruned deps+      [ (pkg', pruneOptionalDependencies pkg')+      | pkg <- pkgs+      , let pkg' = mapConfiguredPackage+                     (pruneOptionalStanzas . setBuildTargets) pkg+      ]+      (Map.keys perPkgTargetsMap)+  where+    -- Elaborate and set the targets we'll build for this package. This is just+    -- based on the targets from the user, not targets implied by reverse+    -- depencencies. Those comes in the second pass once we know the rev deps.+    --+    setBuildTargets pkg =+        pkg {+          pkgBuildTargets   = buildTargets,+          pkgReplTarget     = replTarget,+          pkgBuildHaddocks  = buildHaddocks+        }+      where+        (buildTargets, replTarget, buildHaddocks)+                = elaboratePackageTargets pkg targets+        targets = fromMaybe []+                $ Map.lookup (installedPackageId pkg) perPkgTargetsMap++    -- Decide whether or not to enable testsuites and benchmarks+    --+    -- The testsuite and benchmark targets are somewhat special in that we need+    -- to configure the packages with them enabled, and we need to do that even+    -- if we only want to build one of several testsuites.+    --+    -- There are two cases in which we will enable the testsuites (or+    -- benchmarks): if one of the targets is a testsuite, or if all of the+    -- testsuite depencencies are already cached in the store. The rationale+    -- for the latter is to minimise how often we have to reconfigure due to+    -- the particular targets we choose to build. Otherwise choosing to build+    -- a testsuite target, and then later choosing to build an exe target+    -- would involve unnecessarily reconfiguring the package with testsuites+    -- disabled. Technically this introduces a little bit of stateful+    -- behaviour to make this "sticky", but it should be benign.+    --+    pruneOptionalStanzas pkg = pkg { pkgStanzasEnabled = stanzas }+      where+        stanzas :: Set OptionalStanza+        stanzas = optionalStanzasRequiredByTargets  pkg+               <> optionalStanzasRequestedByDefault pkg+               <> optionalStanzasWithDepsAvailable availablePkgs pkg++    -- Calculate package depencencies but cut out those needed only by+    -- optional stanzas that we've determined we will not enable.+    -- These pruned deps are not persisted in this pass since they're based on+    -- the optional stanzas and we'll make further tweaks to the optional+    -- stanzas in the next pass.+    --+    pruneOptionalDependencies :: ElaboratedPlanPackage -> [InstalledPackageId]+    pruneOptionalDependencies (InstallPlan.Configured pkg) =+        (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg)+      where+        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas+        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas+        keepNeeded _                     _ = True+        stanzas = pkgStanzasEnabled pkg+    pruneOptionalDependencies pkg =+        CD.flatDeps (depends pkg)++    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage+                                     -> Set OptionalStanza+    optionalStanzasRequiredByTargets pkg =+      Set.fromList+        [ stanza+        | ComponentTarget cname _ <- pkgBuildTargets pkg+                                  ++ maybeToList (pkgReplTarget pkg)+        , stanza <- maybeToList (componentOptionalStanza cname)+        ]++    optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage+                                      -> Set OptionalStanza+    optionalStanzasRequestedByDefault =+        Map.keysSet+      . Map.filter (id :: Bool -> Bool)+      . pkgStanzasRequested++    availablePkgs =+      Set.fromList+        [ installedPackageId pkg+        | InstallPlan.PreExisting pkg <- pkgs ]++optionalStanzasWithDepsAvailable :: Set InstalledPackageId+                                 -> ElaboratedConfiguredPackage+                                 -> Set OptionalStanza+optionalStanzasWithDepsAvailable availablePkgs pkg =+    Set.fromList+      [ stanza+      | stanza <- Set.toList (pkgStanzasAvailable pkg)+      , let deps :: [InstalledPackageId]+            deps = map installedPackageId+                 $ CD.select (optionalStanzaDeps stanza)+                             (pkgDependencies pkg)+      , all (`Set.member` availablePkgs) deps+      ]+  where+    optionalStanzaDeps TestStanzas  (CD.ComponentTest  _) = True+    optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True+    optionalStanzaDeps _            _                     = False+++-- The second pass does three things:+--+-- * A second go at deciding which optional stanzas to enable.+-- * Prune the depencencies based on the final choice of optional stanzas.+-- * Extend the targets within each package to build, now we know the reverse+--   depencencies, ie we know which libs are needed as deps by other packages.+--+-- Achieving sticky behaviour with enabling\/disabling optional stanzas is+-- tricky. The first approximation was handled by the first pass above, but+-- it's not quite enough. That pass will enable stanzas if all of the deps+-- of the optional stanza are already instaled /in the store/. That's important+-- but it does not account for depencencies that get built inplace as part of+-- the project. We cannot take those inplace build deps into account in the+-- pruning pass however because we don't yet know which ones we're going to+-- build. Once we do know, we can have another go and enable stanzas that have+-- all their deps available. Now we can consider all packages in the pruned+-- plan to be available, including ones we already decided to build from+-- source.+--+-- Deciding which targets to build depends on knowing which packages have+-- reverse dependencies (ie are needed). This requires the result of first+-- pass, which is another reason we have to split it into two passes.+--+-- Note that just because we might enable testsuites or benchmarks (in the+-- first or second pass) doesn't mean that we build all (or even any) of them.+-- That depends on which targets we picked in the first pass.+--+pruneInstallPlanPass2 :: [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass2 pkgs =+    map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs+  where+    setStanzasDepsAndTargets pkg =+        pkg {+          pkgStanzasEnabled = stanzas,+          pkgDependencies   = CD.filterDeps keepNeeded (pkgDependencies pkg),+          pkgBuildTargets   = pkgBuildTargets pkg ++ targetsRequiredForRevDeps+        }+      where+        stanzas :: Set OptionalStanza+        stanzas = pkgStanzasEnabled pkg+               <> optionalStanzasWithDepsAvailable availablePkgs pkg++        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas+        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas+        keepNeeded _                     _ = True++        targetsRequiredForRevDeps =+          [ ComponentTarget (Cabal.defaultLibName (pkgSourceId pkg)) WholeComponent+          -- if anything needs this pkg, build the library component+          | installedPackageId pkg `Set.member` hasReverseLibDeps+          ]+        --TODO: also need to track build-tool rev-deps for exes++    availablePkgs :: Set InstalledPackageId+    availablePkgs = Set.fromList (map installedPackageId pkgs)++    hasReverseLibDeps :: Set InstalledPackageId+    hasReverseLibDeps =+      Set.fromList [ depid | pkg <- pkgs+                           , depid <- CD.flatDeps (depends pkg) ]+++mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage)+                     -> ElaboratedPlanPackage+                     -> ElaboratedPlanPackage+mapConfiguredPackage f (InstallPlan.Configured pkg) =+  InstallPlan.Configured (f pkg)+mapConfiguredPackage _ pkg = pkg++componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza+componentOptionalStanza (Cabal.CTestName  _) = Just TestStanzas+componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas+componentOptionalStanza _                    = Nothing+++dependencyClosure :: (pkg -> InstalledPackageId)+                  -> (pkg -> [InstalledPackageId])+                  -> [pkg]+                  -> [InstalledPackageId]+                  -> [pkg]+dependencyClosure pkgid deps allpkgs =+    map vertexToPkg+  . concatMap Tree.flatten+  . Graph.dfs graph+  . map pkgidToVertex+  where+    (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs++dependencyGraph :: (pkg -> InstalledPackageId)+                -> (pkg -> [InstalledPackageId])+                -> [pkg]+                -> (Graph.Graph,+                    Graph.Vertex -> pkg,+                    InstalledPackageId -> Graph.Vertex)+dependencyGraph pkgid deps pkgs =+    (graph, vertexToPkg', pkgidToVertex')+  where+    (graph, vertexToPkg, pkgidToVertex) =+      Graph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg )+                           | pkg <- pkgs ]+    vertexToPkg'   = (\(pkg,_,_) -> pkg)+                   . vertexToPkg+    pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure")+                   . pkgidToVertex+++---------------------------+-- Setup.hs script policy+--++-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the+-- solver phase, and part in the elaboration phase. We keep the helper+-- functions for both phases together here so at least you can see all of it+-- in one place.++-- | There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API. In case 3 we also have+-- to build an external Setup.hs script because the package needs a later+-- Cabal lib version than we can support internally.+--+data SetupScriptStyle = SetupCustomExplicitDeps+                      | SetupCustomImplicitDeps+                      | SetupNonCustomExternalLib+                      | SetupNonCustomInternalLib+  deriving (Eq, Show, Generic)++instance Binary SetupScriptStyle+++-- | Work out the 'SetupScriptStyle' given the package description.+--+-- This only works on original packages before we give them to the solver,+-- since after the solver some implicit setup deps are made explicit.+--+-- See 'rememberImplicitSetupDeps' and 'packageSetupScriptStylePostSolver'.+--+packageSetupScriptStylePreSolver :: PD.PackageDescription -> SetupScriptStyle+packageSetupScriptStylePreSolver pkg+  | buildType == PD.Custom+  , isJust (PD.setupBuildInfo pkg)+  = SetupCustomExplicitDeps++  | buildType == PD.Custom+  = SetupCustomImplicitDeps++  | PD.specVersion pkg > cabalVersion -- one cabal-install is built against+  = SetupNonCustomExternalLib++  | otherwise+  = SetupNonCustomInternalLib+  where+    buildType = fromMaybe PD.Custom (PD.buildType pkg)+++-- | Part of our Setup.hs handling policy is implemented by getting the solver+-- to work out setup dependencies for packages. The solver already handles+-- packages that explicitly specify setup dependencies, but we can also tell+-- the solver to treat other packages as if they had setup dependencies.+-- That's what this function does, it gets called by the solver for all+-- packages that don't already have setup dependencies.+--+-- The dependencies we want to add is different for each 'SetupScriptStyle'.+--+-- Note that adding default deps means these deps are actually /added/ to the+-- packages that we get out of the solver in the 'SolverInstallPlan'. Making+-- implicit setup deps explicit is a problem in the post-solver stages because+-- we still need to distinguish the case of explicit and implict setup deps.+-- See 'rememberImplicitSetupDeps'.+--+defaultSetupDeps :: Platform -> PD.PackageDescription -> [Dependency]+defaultSetupDeps platform pkg =+    case packageSetupScriptStylePreSolver pkg of++      -- For packages with build type custom that do not specify explicit+      -- setup dependencies, we add a dependency on Cabal and a number+      -- of other packages.+      SetupCustomImplicitDeps ->+        [ Dependency depPkgname anyVersion+        | depPkgname <- legacyCustomSetupPkgs platform ] +++        -- The Cabal dep is slightly special:+        --  * we omit the dep for the Cabal lib itself (since it bootstraps),+        --  * we constrain it to be less than 1.23 since all packages+        --    relying on later Cabal spec versions are supposed to use+        --    explit setup deps. Having this constraint also allows later+        --    Cabal lib versions to make breaking API changes without breaking+        --    all old Setup.hs scripts.+        [ Dependency cabalPkgname cabalConstraint+        | packageName pkg /= cabalPkgname ]+        where+          cabalConstraint   = orLaterVersion (PD.specVersion pkg)+                                `intersectVersionRanges`+                              earlierVersion cabalCompatMaxVer+        -- TODO/FIXME: turns out that constraining to less than 1.23 causes+        --             problems with GHC8 as there's too many important packages+        --             with Custom build-type, for which there wouldn't be any+        --             install-plan (as GHC8 requires Cabal-1.24+). So let's+        --             set an implicit upper bound `Cabal < 2` instead.+          cabalCompatMaxVer = Version [2] []++      -- For other build types (like Simple) if we still need to compile an+      -- external Setup.hs, it'll be one of the simple ones that only depends+      -- on Cabal and base.+      SetupNonCustomExternalLib ->+        [ Dependency cabalPkgname cabalConstraint+        , Dependency basePkgname  anyVersion ]+        where+          cabalConstraint = orLaterVersion (PD.specVersion pkg)++      -- The internal setup wrapper method has no deps at all.+      SetupNonCustomInternalLib -> []++      SetupCustomExplicitDeps ->+        error $ "defaultSetupDeps: called for a package with explicit "+             ++ "setup deps: " ++ display (packageId pkg)+++-- | See 'rememberImplicitSetupDeps' for details.+type PackagesImplicitSetupDeps = Set InstalledPackageId++-- | A consequence of using 'defaultSetupDeps' in 'planPackages' is that by+-- making implicit setup deps explicit we loose track of which packages+-- originally had implicit setup deps. That's important because we do still+-- have different behaviour based on the setup style (in particular whether to+-- compile a Setup.hs script with version macros).+--+-- So we remember the necessary information in an auxilliary set and use it+-- in 'packageSetupScriptStylePreSolver' to recover the full info.+--+rememberImplicitSetupDeps :: SourcePackageIndex.PackageIndex (SourcePackage loc)+                          -> SolverInstallPlan+                          -> (SolverInstallPlan, PackagesImplicitSetupDeps)+rememberImplicitSetupDeps sourcePkgIndex plan =+    (plan, pkgsImplicitSetupDeps)+  where+    pkgsImplicitSetupDeps =+      Set.fromList+        [ installedPackageId pkg+        | InstallPlan.Configured+            pkg@(ConfiguredPackage newpkg _ _ _) <- InstallPlan.toList plan+          -- has explicit setup deps now+        , hasExplicitSetupDeps newpkg+          -- but originally had no setup deps+        , let Just origpkg = SourcePackageIndex.lookupPackageId+                               sourcePkgIndex (packageId pkg)+        , not (hasExplicitSetupDeps origpkg)+        ]++    hasExplicitSetupDeps =+        (SetupCustomExplicitDeps==)+      . packageSetupScriptStylePreSolver+      . PD.packageDescription . packageDescription+++-- | Use the extra info saved by 'rememberImplicitSetupDeps' to let us work+-- out the correct 'SetupScriptStyle'. This should give the same result as+-- 'packageSetupScriptStylePreSolver' gave prior to munging the package info+-- through the solver.+--+packageSetupScriptStylePostSolver :: Set InstalledPackageId+                                  -> ConfiguredPackage loc+                                  -> PD.PackageDescription+                                  -> SetupScriptStyle+packageSetupScriptStylePostSolver pkgsImplicitSetupDeps pkg pkgDescription =+    case packageSetupScriptStylePreSolver pkgDescription of+      SetupCustomExplicitDeps+        | Set.member (installedPackageId pkg) pkgsImplicitSetupDeps+            -> SetupCustomImplicitDeps+      other -> other+++-- | Work out which version of the Cabal spec we will be using to talk to the+-- Setup.hs interface for this package.+--+-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result+-- of what the solver picked for us, based on the explicit setup deps or the+-- ones added implicitly by 'defaultSetupDeps'.+--+packageSetupScriptSpecVersion :: Package pkg+                              => SetupScriptStyle+                              -> PD.PackageDescription+                              -> ComponentDeps [pkg]+                              -> Version++-- We're going to be using the internal Cabal library, so the spec version of+-- that is simply the version of the Cabal library that cabal-install has been+-- built with.+packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ =+    cabalVersion++-- If we happen to be building the Cabal lib itself then because that+-- bootstraps itself then we use the version of the lib we're building.+packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _+  | packageName pkg == cabalPkgname+  = packageVersion pkg++-- In all other cases we have a look at what version of the Cabal lib the+-- solver picked. Or if it didn't depend on Cabal at all (which is very rare)+-- then we look at the .cabal file to see what spec version it declares.+packageSetupScriptSpecVersion _ pkg deps =+    case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of+      Just dep -> packageVersion dep+      Nothing  -> PD.specVersion pkg+++cabalPkgname, basePkgname :: PackageName+cabalPkgname = PackageName "Cabal"+basePkgname  = PackageName "base"+++legacyCustomSetupPkgs :: Platform -> [PackageName]+legacyCustomSetupPkgs (Platform _ os) =+    map PackageName $+        [ "array", "base", "binary", "bytestring", "containers"+        , "deepseq", "directory", "filepath", "pretty"+        , "process", "time" ]+     ++ [ "Win32" | os == Windows ]+     ++ [ "unix"  | os /= Windows ]++-- The other aspects of our Setup.hs policy lives here where we decide on+-- the 'SetupScriptOptions'.+--+-- Our current policy for the 'SetupCustomImplicitDeps' case is that we+-- try to make the implicit deps cover everything, and we don't allow the+-- compiler to pick up other deps. This may or may not be sustainable, and+-- we might have to allow the deps to be non-exclusive, but that itself would+-- be tricky since we would have to allow the Setup access to all the packages+-- in the store and local dbs.++setupHsScriptOptions :: ElaboratedReadyPackage+                     -> ElaboratedSharedConfig+                     -> FilePath+                     -> FilePath+                     -> Bool+                     -> Lock+                     -> SetupScriptOptions+setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..})+                     ElaboratedSharedConfig{..} srcdir builddir+                     isParallelBuild cacheLock =+    SetupScriptOptions {+      useCabalVersion          = thisVersion pkgSetupScriptCliVersion,+      useCabalSpecVersion      = Just pkgSetupScriptCliVersion,+      useCompiler              = Just pkgConfigCompiler,+      usePlatform              = Just pkgConfigPlatform,+      usePackageDB             = pkgSetupPackageDBStack,+      usePackageIndex          = Nothing,+      useDependencies          = [ (uid, srcid)+                                 | ConfiguredId srcid uid <- CD.setupDeps pkgDependencies ],+      useDependenciesExclusive = True,+      useVersionMacros         = pkgSetupScriptStyle == SetupCustomExplicitDeps,+      useProgramConfig         = pkgConfigProgramDb,+      useDistPref              = builddir,+      useLoggingHandle         = Nothing, -- this gets set later+      useWorkingDir            = Just srcdir,+      useWin32CleanHack        = False,   --TODO: [required eventually]+      forceExternalSetupMethod = isParallelBuild,+      setupCacheLock           = Just cacheLock+    }+++-- | To be used for the input for elaborateInstallPlan.+--+-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.+--+userInstallDirTemplates :: Compiler+                        -> IO InstallDirs.InstallDirTemplates+userInstallDirTemplates compiler = do+    InstallDirs.defaultInstallDirs+                  (compilerFlavor compiler)+                  True  -- user install+                  False -- unused++storePackageInstallDirs :: CabalDirLayout+                        -> CompilerId+                        -> InstalledPackageId+                        -> InstallDirs.InstallDirs FilePath+storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory}+                        compid ipkgid =+    InstallDirs.InstallDirs {..}+  where+    prefix       = cabalStorePackageDirectory compid ipkgid+    bindir       = prefix </> "bin"+    libdir       = prefix </> "lib"+    libsubdir    = ""+    dynlibdir    = libdir+    libexecdir   = prefix </> "libexec"+    includedir   = libdir </> "include"+    datadir      = prefix </> "share"+    datasubdir   = ""+    docdir       = datadir </> "doc"+    mandir       = datadir </> "man"+    htmldir      = docdir  </> "html"+    haddockdir   = htmldir+    sysconfdir   = prefix </> "etc"+++--TODO: [code cleanup] perhaps reorder this code+-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,+-- make the various Setup.hs {configure,build,copy} flags+++setupHsConfigureFlags :: ElaboratedReadyPackage+                      -> ElaboratedSharedConfig+                      -> Verbosity+                      -> FilePath+                      -> Cabal.ConfigFlags+setupHsConfigureFlags (ReadyPackage+                         pkg@ElaboratedConfiguredPackage{..})+                      sharedConfig@ElaboratedSharedConfig{..}+                      verbosity builddir =+    assert (sanityCheckElaboratedConfiguredPackage sharedConfig pkg)+    Cabal.ConfigFlags {..}+  where+    configDistPref            = toFlag builddir+    configVerbosity           = toFlag verbosity++    configIPID                = toFlag (display (installedUnitId pkg))++    configProgramPaths        = programDbProgramPaths pkgConfigProgramDb+    configProgramArgs         = programDbProgramArgs  pkgConfigProgramDb+    configProgramPathExtra    = programDbPathExtra    pkgConfigProgramDb+    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)+    configHcPath              = mempty -- use configProgramPaths instead+    configHcPkg               = mempty -- use configProgramPaths instead++    configVanillaLib          = toFlag pkgVanillaLib+    configSharedLib           = toFlag pkgSharedLib+    configDynExe              = toFlag pkgDynExe+    configGHCiLib             = toFlag pkgGHCiLib+    configProfExe             = mempty+    configProfLib             = toFlag pkgProfLib+    configProf                = toFlag pkgProfExe++    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail+    -- so we specify both so we can specify independently+    configProfDetail          = toFlag pkgProfExeDetail+    configProfLibDetail       = toFlag pkgProfLibDetail++    configCoverage            = toFlag pkgCoverage+    configLibCoverage         = mempty++    configOptimization        = toFlag pkgOptimization+    configSplitObjs           = toFlag pkgSplitObjs+    configStripExes           = toFlag pkgStripExes+    configStripLibs           = toFlag pkgStripLibs+    configDebugInfo           = toFlag pkgDebugInfo+    configAllowNewer          = mempty -- we use configExactConfiguration True++    configConfigurationsFlags = pkgFlagAssignment+    configConfigureArgs       = pkgConfigureScriptArgs+    configExtraLibDirs        = pkgExtraLibDirs+    configExtraFrameworkDirs  = pkgExtraFrameworkDirs+    configExtraIncludeDirs    = pkgExtraIncludeDirs+    configProgPrefix          = maybe mempty toFlag pkgProgPrefix+    configProgSuffix          = maybe mempty toFlag pkgProgSuffix++    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)+                                     pkgInstallDirs++    -- we only use configDependencies, unless we're talking to an old Cabal+    -- in which case we use configConstraints+    configDependencies        = [ (packageName srcid, uid)+                                | ConfiguredId srcid uid <- CD.nonSetupDeps pkgDependencies ]+    configConstraints         = [ thisPackageVersion srcid+                                | ConfiguredId srcid _uid <- CD.nonSetupDeps pkgDependencies ]++    -- explicitly clear, then our package db stack+    -- TODO: [required eventually] have to do this differently for older Cabal versions+    configPackageDBs          = Nothing : map Just pkgBuildPackageDBStack++    configTests               = toFlag (TestStanzas  `Set.member` pkgStanzasEnabled)+    configBenchmarks          = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled)++    configExactConfiguration  = toFlag True+    configFlagError           = mempty --TODO: [research required] appears not to be implemented+    configRelocatable         = mempty --TODO: [research required] ???+    configScratchDir          = mempty -- never use+    configUserInstall         = mempty -- don't rely on defaults+    configPrograms_           = mempty -- never use, shouldn't exist++    programDbProgramPaths db =+      [ (programId prog, programPath prog)+      | prog <- configuredPrograms db ]++    programDbProgramArgs db =+      [ (programId prog, programOverrideArgs prog)+      | prog <- configuredPrograms db ]++    programDbPathExtra db =+      case getProgramSearchPath db of+        ProgramSearchPathDefault : extra ->+          toNubList [ dir | ProgramSearchPathDir dir <- extra ]+        _ -> error $ "setupHsConfigureFlags: we cannot currently cope with a "+                  ++ "search path that does not start with the system path"+                  -- the Setup.hs interface only has --extra-prog-path+                  -- so we cannot put things before the $PATH, only after+++setupHsBuildFlags :: ElaboratedConfiguredPackage+                  -> ElaboratedSharedConfig+                  -> Verbosity+                  -> FilePath+                  -> Cabal.BuildFlags+setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =+    Cabal.BuildFlags {+      buildProgramPaths = mempty, --unused, set at configure time+      buildProgramArgs  = mempty, --unused, set at configure time+      buildVerbosity    = toFlag verbosity,+      buildDistPref     = toFlag builddir,+      buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),+      buildArgs         = mempty  -- unused, passed via args not flags+    }+++setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]+setupHsBuildArgs pkg =+    map (showComponentTarget pkg) (pkgBuildTargets pkg)+++showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String+showComponentTarget _pkg =+    showBuildTarget . toBuildTarget+  where+    showBuildTarget t =+      Cabal.showBuildTarget (qlBuildTarget t) t++    qlBuildTarget Cabal.BuildTargetComponent{} = Cabal.QL2+    qlBuildTarget _                            = Cabal.QL3++    toBuildTarget :: ComponentTarget -> Cabal.BuildTarget+    toBuildTarget (ComponentTarget cname subtarget) =+      case subtarget of+        WholeComponent     -> Cabal.BuildTargetComponent cname+        ModuleTarget mname -> Cabal.BuildTargetModule    cname mname+        FileTarget   fname -> Cabal.BuildTargetFile      cname fname+++setupHsReplFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.ReplFlags+setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =+    Cabal.ReplFlags {+      replProgramPaths = mempty, --unused, set at configure time+      replProgramArgs  = mempty, --unused, set at configure time+      replVerbosity    = toFlag verbosity,+      replDistPref     = toFlag builddir,+      replReload       = mempty  --only used as callback from repl+    }+++setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]+setupHsReplArgs pkg =+    maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg)+    --TODO: should be able to give multiple modules in one component+++setupHsCopyFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.CopyFlags+setupHsCopyFlags _ _ verbosity builddir =+    Cabal.CopyFlags {+      --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right+      -- thing, but perhaps we ought really to copy into an image dir and do+      -- some sanity checks and move into the final location ourselves+      copyArgs      = [], -- TODO: could use this to only copy what we enabled+      copyDest      = toFlag InstallDirs.NoCopyDest,+      copyDistPref  = toFlag builddir,+      copyVerbosity = toFlag verbosity+    }++setupHsRegisterFlags :: ElaboratedConfiguredPackage+                     -> ElaboratedSharedConfig+                     -> Verbosity+                     -> FilePath+                     -> FilePath+                     -> Cabal.RegisterFlags+setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _+                     verbosity builddir pkgConfFile =+    Cabal.RegisterFlags {+      regPackageDB   = mempty,  -- misfeature+      regGenScript   = mempty,  -- never use+      regGenPkgConf  = toFlag (Just pkgConfFile),+      regInPlace     = case pkgBuildStyle of+                         BuildInplaceOnly -> toFlag True+                         _                -> toFlag False,+      regPrintId     = mempty,  -- never use+      regDistPref    = toFlag builddir,+      regVerbosity   = toFlag verbosity+    }++setupHsHaddockFlags :: ElaboratedConfiguredPackage+                    -> ElaboratedSharedConfig+                    -> Verbosity+                    -> FilePath+                    -> Cabal.HaddockFlags+setupHsHaddockFlags ElaboratedConfiguredPackage{..} _ verbosity builddir =+    Cabal.HaddockFlags {+      haddockProgramPaths  = mempty, --unused, set at configure time+      haddockProgramArgs   = mempty, --unused, set at configure time+      haddockHoogle        = toFlag pkgHaddockHoogle,+      haddockHtml          = toFlag pkgHaddockHtml,+      haddockHtmlLocation  = maybe mempty toFlag pkgHaddockHtmlLocation,+      haddockForHackage    = mempty, --TODO: new flag+      haddockExecutables   = toFlag pkgHaddockExecutables,+      haddockTestSuites    = toFlag pkgHaddockTestSuites,+      haddockBenchmarks    = toFlag pkgHaddockBenchmarks,+      haddockInternal      = toFlag pkgHaddockInternal,+      haddockCss           = maybe mempty toFlag pkgHaddockCss,+      haddockHscolour      = toFlag pkgHaddockHscolour,+      haddockHscolourCss   = maybe mempty toFlag pkgHaddockHscolourCss,+      haddockContents      = maybe mempty toFlag pkgHaddockContents,+      haddockDistPref      = toFlag builddir,+      haddockKeepTempFiles = mempty, --TODO: from build settings+      haddockVerbosity     = toFlag verbosity+    }++{-+setupHsTestFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.TestFlags+setupHsTestFlags _ _ verbosity builddir =+    Cabal.TestFlags {+    }+-}++------------------------------------------------------------------------------+-- * Sharing installed packages+------------------------------------------------------------------------------++--+-- Nix style store management for tarball packages+--+-- So here's our strategy:+--+-- We use a per-user nix-style hashed store, but /only/ for tarball packages.+-- So that includes packages from hackage repos (and other http and local+-- tarballs). For packages in local directories we do not register them into+-- the shared store by default, we just build them locally inplace.+--+-- The reason we do it like this is that it's easy to make stable hashes for+-- tarball packages, and these packages benefit most from sharing. By contrast+-- unpacked dir packages are harder to hash and they tend to change more+-- frequently so there's less benefit to sharing them.+--+-- When using the nix store approach we have to run the solver *without*+-- looking at the packages installed in the store, just at the source packages+-- (plus core\/global installed packages). Then we do a post-processing pass+-- to replace configured packages in the plan with pre-existing ones, where+-- possible. Where possible of course means where the nix-style package hash+-- equals one that's already in the store.+--+-- One extra wrinkle is that unless we know package tarball hashes upfront, we+-- will have to download the tarballs to find their hashes. So we have two+-- options: delay replacing source with pre-existing installed packages until+-- the point during the execution of the install plan where we have the+-- tarball, or try to do as much up-front as possible and then check again+-- during plan execution. The former isn't great because we would end up+-- telling users we're going to re-install loads of packages when in fact we+-- would just share them. It'd be better to give as accurate a prediction as+-- we can. The latter is better for users, but we do still have to check+-- during plan execution because it's important that we don't replace existing+-- installed packages even if they have the same package hash, because we+-- don't guarantee ABI stability.++-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but+-- not replace installed packages with ghc-pkg.++packageHashInputs :: ElaboratedSharedConfig+                  -> ElaboratedConfiguredPackage+                  -> PackageHashInputs+packageHashInputs+    pkgshared+    pkg@ElaboratedConfiguredPackage{+      pkgSourceId,+      pkgSourceHash = Just srchash,+      pkgDependencies+    } =+    PackageHashInputs {+      pkgHashPkgId       = pkgSourceId,+      pkgHashSourceHash  = srchash,+      pkgHashDirectDeps  = Set.fromList+                             [ installedPackageId dep+                             | dep <- CD.select relevantDeps pkgDependencies ],+      pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg+    }+  where+    -- Obviously the main deps are relevant+    relevantDeps (CD.ComponentLib _)   = True+    relevantDeps (CD.ComponentExe _)   = True+    -- Setup deps can affect the Setup.hs behaviour and thus what is built+    relevantDeps  CD.ComponentSetup    = True+    -- However testsuites and benchmarks do not get installed and should not+    -- affect the result, so we do not include them.+    relevantDeps (CD.ComponentTest  _) = False+    relevantDeps (CD.ComponentBench _) = False++packageHashInputs _ pkg =+    error $ "packageHashInputs: only for packages with source hashes. "+         ++ display (packageId pkg)++packageHashConfigInputs :: ElaboratedSharedConfig+                        -> ElaboratedConfiguredPackage+                        -> PackageHashConfigInputs+packageHashConfigInputs+    ElaboratedSharedConfig{..}+    ElaboratedConfiguredPackage{..} =++    PackageHashConfigInputs {+      pkgHashCompilerId          = compilerId pkgConfigCompiler,+      pkgHashPlatform            = pkgConfigPlatform,+      pkgHashFlagAssignment      = pkgFlagAssignment,+      pkgHashConfigureScriptArgs = pkgConfigureScriptArgs,+      pkgHashVanillaLib          = pkgVanillaLib,+      pkgHashSharedLib           = pkgSharedLib,+      pkgHashDynExe              = pkgDynExe,+      pkgHashGHCiLib             = pkgGHCiLib,+      pkgHashProfLib             = pkgProfLib,+      pkgHashProfExe             = pkgProfExe,+      pkgHashProfLibDetail       = pkgProfLibDetail,+      pkgHashProfExeDetail       = pkgProfExeDetail,+      pkgHashCoverage            = pkgCoverage,+      pkgHashOptimization        = pkgOptimization,+      pkgHashSplitObjs           = pkgSplitObjs,+      pkgHashStripLibs           = pkgStripLibs,+      pkgHashStripExes           = pkgStripExes,+      pkgHashDebugInfo           = pkgDebugInfo,+      pkgHashExtraLibDirs        = pkgExtraLibDirs,+      pkgHashExtraFrameworkDirs  = pkgExtraFrameworkDirs,+      pkgHashExtraIncludeDirs    = pkgExtraIncludeDirs,+      pkgHashProgPrefix          = pkgProgPrefix,+      pkgHashProgSuffix          = pkgProgSuffix+    }+++-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an+-- 'ElaboratedInstallPlan', replace configured source packages by pre-existing+-- installed packages whenever they exist.+--+improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex+                                          -> ElaboratedInstallPlan+                                          -> ElaboratedInstallPlan+improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan =+    replaceWithPreExisting installPlan+      [ ipkg+      | InstallPlan.Configured pkg+          <- InstallPlan.reverseTopologicalOrder installPlan+      , ipkg <- maybeToList (canPackageBeImproved pkg) ]+  where+    --TODO: sanity checks:+    -- * the installed package must have the expected deps etc+    -- * the installed package must not be broken, valid dep closure++    --TODO: decide what to do if we encounter broken installed packages,+    -- since overwriting is never safe.++    canPackageBeImproved pkg =+      PackageIndex.lookupUnitId+        installedPkgIndex (installedPackageId pkg)++    replaceWithPreExisting =+      foldl' (\plan ipkg -> InstallPlan.preexisting+                              (installedPackageId ipkg) ipkg plan)
+ cabal/cabal-install/Distribution/Client/RebuildMonad.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | An abstraction for re-running actions if values or files have changed.+--+-- This is not a full-blown make-style incremental build system, it's a bit+-- more ad-hoc than that, but it's easier to integrate with existing code.+--+-- It's a convenient interface to the "Distribution.Client.FileMonitor"+-- functions.+--+module Distribution.Client.RebuildMonad (+    -- * Rebuild monad+    Rebuild,+    runRebuild,++    -- * Setting up file monitoring+    monitorFiles,+    MonitorFilePath,+    monitorFile,+    monitorFileHashed,+    monitorNonExistentFile,+    monitorDirectory,+    monitorDirectoryExistence,+    monitorFileOrDirectory,+    monitorFileSearchPath,+    monitorFileHashedSearchPath,+    -- ** Monitoring file globs+    monitorFileGlob,+    FilePathGlob(..),+    FilePathRoot(..),+    FilePathGlobRel(..),+    GlobPiece(..),++    -- * Using a file monitor+    FileMonitor(..),+    newFileMonitor,+    rerunIfChanged,++    -- * Utils+    matchFileGlob,+  ) where++import Distribution.Client.FileMonitor+import Distribution.Client.Glob hiding (matchFileGlob)+import qualified Distribution.Client.Glob as Glob (matchFileGlob)++import Distribution.Simple.Utils (debug)+import Distribution.Verbosity    (Verbosity)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad.State as State+import Distribution.Compat.Binary     (Binary)+import System.FilePath (takeFileName)+++-- | A monad layered on top of 'IO' to help with re-running actions when the+-- input files and values they depend on change. The crucial operations are+-- 'rerunIfChanged' and 'monitorFiles'.+--+newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a)+  deriving (Functor, Applicative, Monad, MonadIO)++-- | Use this wihin the body action of 'rerunIfChanged' to declare that the+-- action depends on the given files. This can be based on what the action+-- actually did. It is these files that will be checked for changes next+-- time 'rerunIfChanged' is called for that 'FileMonitor'.+--+monitorFiles :: [MonitorFilePath] -> Rebuild ()+monitorFiles filespecs = Rebuild (State.modify (filespecs++))++-- | Run a 'Rebuild' IO action.+unRebuild :: Rebuild a -> IO (a, [MonitorFilePath])+unRebuild (Rebuild action) = runStateT action []++-- | Run a 'Rebuild' IO action.+runRebuild :: Rebuild a -> IO a+runRebuild (Rebuild action) = evalStateT action []++-- | This captures the standard use pattern for a 'FileMonitor': given a+-- monitor, an action and the input value the action depends on, either+-- re-run the action to get its output, or if the value and files the action+-- depends on have not changed then return a previously cached action result.+--+-- The result is still in the 'Rebuild' monad, so these can be nested.+--+-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.+--+rerunIfChanged :: (Binary a, Binary b)+               => Verbosity+               -> FilePath+               -> FileMonitor a b+               -> a+               -> Rebuild b+               -> Rebuild b+rerunIfChanged verbosity rootDir monitor key action = do+    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key+    case changed of+      MonitorUnchanged result files -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                                    ++ "' unchanged."+        monitorFiles files+        return result++      MonitorChanged reason -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                ++ "' changed: " ++ showReason reason+        startTime <- liftIO $ beginUpdateFileMonitor+        (result, files) <- liftIO $ unRebuild action+        liftIO $ updateFileMonitor monitor rootDir+                                   (Just startTime) files key result+        monitorFiles files+        return result+  where+    monitorName = takeFileName (fileMonitorCacheFile monitor)++    showReason (MonitoredFileChanged file) = "file " ++ file+    showReason (MonitoredValueChanged _)   = "monitor value changed"+    showReason  MonitorFirstRun            = "first run"+    showReason  MonitorCorruptCache        = "invalid cache file"+++-- | Utility to match a file glob against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- Since this operates in the 'Rebuild' monad, it also monitrs the given glob+-- for changes.+--+matchFileGlob :: FilePath -> FilePathGlob -> Rebuild [FilePath]+matchFileGlob root glob = do+    monitorFiles [monitorFileGlob glob]+    liftIO $ Glob.matchFileGlob root glob+
cabal/cabal-install/Distribution/Client/Sandbox.hs view
@@ -38,18 +38,17 @@     updateSandboxConfigFileFlag,     updateInstallDirs, -    -- FIXME: move somewhere else-    configPackageDB', configCompilerAux'+    configPackageDB', configCompilerAux', getPersistOrConfigCompiler   ) where  import Distribution.Client.Setup   ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)   , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags-  , defaultSandboxLocation, globalRepos )+  , defaultSandboxLocation, withRepoContext ) import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps                                               , maybeAddCompilerTimestampRecord                                               , withAddTimestamps-                                              , withRemoveTimestamps )+                                              , removeTimestamps ) import Distribution.Client.Config   ( SavedConfig(..), defaultUserInstall, loadConfig ) import Distribution.Client.Dependency         ( foldProgress )@@ -65,7 +64,8 @@   , createPackageEnvironmentFile, classifyPackageEnvironment   , tryLoadSandboxPackageEnvironmentFile, loadUserConfig   , commentPackageEnvironment, showPackageEnvironmentWithComments-  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile )+  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile+  , sandboxPackageDBPath ) import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)                                               , UseSandbox(..) ) import Distribution.Client.SetupWrapper@@ -73,7 +73,7 @@ import Distribution.Client.Types              ( PackageLocation(..)                                               , SourcePackage(..) ) import Distribution.Client.Utils              ( inDir, tryCanonicalizePath-                                              , tryFindAddSourcePackageDesc )+                                              , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration                                               ( flattenPackageDescription ) import Distribution.PackageDescription.Parse  ( readPackageDescription )@@ -82,11 +82,14 @@ import Distribution.Simple.Configure          ( configCompilerAuxEx                                               , interpretPackageDbFlags                                               , getPackageDBContents+                                              , maybeGetPersistBuildConfig+                                              , findDistPrefOrDefault                                               , findDistPref )+import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import Distribution.Simple.PreProcess         ( knownSuffixHandlers ) import Distribution.Simple.Program            ( ProgramConfiguration ) import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)-                                              , fromFlagOrDefault )+                                              , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist            ( prepareTree ) import Distribution.Simple.Utils              ( die, debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc@@ -104,19 +107,25 @@ import qualified Distribution.Simple.Register      as Register import qualified Data.Map                          as M import qualified Data.Set                          as S+import Data.Either                            (partitionEithers) import Control.Exception                      ( assert, bracket_ )-import Control.Monad                          ( forM, liftM2, unless, when )+import Control.Monad                          ( forM, liftM, liftM2, unless, when ) import Data.Bits                              ( shiftL, shiftR, xor ) import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef )-import Data.List                              ( delete, foldl' )+import Data.List                              ( delete+                                              , foldl'+                                              , intersperse+                                              , isPrefixOf+                                              , groupBy ) import Data.Maybe                             ( fromJust ) #if !MIN_VERSION_base(4,8,0) import Data.Monoid                            ( mempty, mappend ) #endif import Data.Word                              ( Word32 ) import Numeric                                ( showHex )-import System.Directory                       ( createDirectory+import System.Directory                       ( canonicalizePath+                                              , createDirectory                                               , doesDirectoryExist                                               , doesFileExist                                               , getCurrentDirectory@@ -126,9 +135,9 @@ import System.FilePath                        ( (</>), equalFilePath                                               , getSearchPath                                               , searchPathSeparator+                                              , splitSearchPath                                               , takeDirectory ) - -- -- * Constants --@@ -362,9 +371,28 @@         ++ "'.\nAssuming a shared sandbox. Please delete '"         ++ sandboxDir ++ "' manually." -      notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir-      removeDirectoryRecursive sandboxDir+      absSandboxDir <- canonicalizePath sandboxDir+      notice verbosity $ "Deleting the sandbox located at " ++ absSandboxDir+      removeDirectoryRecursive absSandboxDir +      let+        pathInsideSandbox = isPrefixOf absSandboxDir++        -- Warn the user if deleting the sandbox deleted a package database+        -- referenced in the current environment.+        checkPackagePaths var = do+          let+            checkPath path = do+              absPath <- canonicalizePath path+              (when (pathInsideSandbox absPath) . warn verbosity)+                (var ++ " refers to package database " ++ path+                 ++ " inside the deleted sandbox.")+          liftM (maybe [] splitSearchPath) (lookupEnv var) >>= mapM_ checkPath++      checkPackagePaths "CABAL_SANDBOX_PACKAGE_PATH"+      checkPackagePaths "GHC_PACKAGE_PATH"+      checkPackagePaths "GHCJS_PACKAGE_PATH"+ -- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'. doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment                -> BuildTreeRefType@@ -380,7 +408,7 @@     (compilerId comp) platform    withAddTimestamps sandboxDir $ do-    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it+    -- Path canonicalisation is done in addBuildTreeRefs, but we do it     -- twice because of the timestamps file.     buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs     Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType@@ -448,14 +476,54 @@   (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) -  withRemoveTimestamps sandboxDir $ do+  (results, convDict) <-     Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs +  let (failedPaths, removedPaths) = partitionEithers results+      removedRefs = fmap convDict removedPaths++  unless (null removedPaths) $ do+    removeTimestamps sandboxDir removedPaths++    notice verbosity $ "Success deleting sources: " +++      showL removedRefs ++ "\n\n"++  unless (null failedPaths) $ do+    let groupedFailures = groupBy errorType failedPaths+    mapM_ handleErrors groupedFailures+    die $ "The sources with the above errors were skipped. (" +++      showL (fmap getPath failedPaths) ++ ")"+   notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++     "source dependency, but does not remove the package " ++     "from the sandbox package DB.\n\n" ++     "Use 'sandbox hc-pkg -- unregister' to do that."+  where+    getPath (Index.ErrNonregisteredSource p) = p+    getPath (Index.ErrNonexistentSource p) = p +    showPaths f = concat . intersperse " " . fmap (show . f)++    showL = showPaths id++    showE [] = return ' '+    showE errs = showPaths getPath errs++    errorType Index.ErrNonregisteredSource{} Index.ErrNonregisteredSource{} =+      True+    errorType Index.ErrNonexistentSource{} Index.ErrNonexistentSource{} = True+    errorType _ _ = False++    handleErrors [] = return ()+    handleErrors errs@(Index.ErrNonregisteredSource{}:_) =+      warn verbosity ("Sources not registered: " ++ showE errs ++ "\n\n")+    handleErrors errs@(Index.ErrNonexistentSource{}:_)   =+      warn verbosity+      ("Source directory not found for paths: " ++ showE errs ++ "\n"+       ++ "If you are trying to delete a reference to a removed directory, "+       ++ "please provide the full absolute path "+       ++ "(as given by `sandbox list-sources`).\n\n")+ -- | Entry point for the 'cabal sandbox list-sources' command. sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags                       -> IO ()@@ -479,11 +547,13 @@ -- tool with provided arguments, restricted to the sandbox. sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do-  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv-      dbStack     = configPackageDB' configFlags-  (comp, _platform, conf) <- configCompilerAux' configFlags-+  -- Invoke hc-pkg for the most recently configured compiler (if any),+  -- using the right package-db for the compiler (see #1935).+  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags+  let dir         = sandboxPackageDBPath sandboxDir comp platform+      dbStack     = [GlobalPackageDB, SpecificPackageDB dir]   Register.invokeHcPkg verbosity comp conf dbStack extraArgs  updateInstallDirs :: Flag Bool@@ -517,7 +587,7 @@ loadConfigOrSandboxConfig verbosity globalFlags = do   let configFileFlag        = globalConfigFile        globalFlags       sandboxConfigFileFlag = globalSandboxConfigFile globalFlags-      ignoreSandboxFlag     = globalIgnoreSandbox globalFlags+      ignoreSandboxFlag     = globalIgnoreSandbox     globalFlags    pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag   pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag@@ -533,7 +603,7 @@     -- Only @cabal.config@ is present.     UserPackageEnvironment    -> do       config <- loadConfig verbosity configFileFlag-      userConfig <- loadUserConfig verbosity pkgEnvDir+      userConfig <- loadUserConfig verbosity pkgEnvDir Nothing       let config' = config `mappend` userConfig       dieIfSandboxRequired config'       return (NoSandbox, config')@@ -541,8 +611,13 @@     -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.     AmbientPackageEnvironment -> do       config <- loadConfig verbosity configFileFlag+      let globalConstraintsOpt =+            flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config+      globalConstraintConfig <-+        loadUserConfig verbosity pkgEnvDir globalConstraintsOpt+      let config' = config `mappend` globalConstraintConfig       dieIfSandboxRequired config-      return (NoSandbox, config)+      return (NoSandbox, config')    where     -- Return the path to the package environment directory - either the@@ -605,9 +680,10 @@                          comp platform conf sandboxDir $ \sandboxPkgInfo ->     unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do +     withRepoContext verbosity globalFlags $ \repoContext -> do       let args :: InstallArgs           args = ((configPackageDB' configFlags)-                 ,(globalRepos globalFlags)+                 ,repoContext                  ,comp, platform, conf                  ,UseSandbox sandboxDir, Just sandboxPkgInfo                  ,globalFlags, configFlags, configExFlags, installFlags@@ -630,7 +706,9 @@       die' message = die (message ++ installFailedInSandbox)       -- TODO: use a better error message, remove duplication.       installFailedInSandbox =-        "Note: when using a sandbox, all packages are required to have consistent dependencies. Try reinstalling/unregistering the offending packages or recreating the sandbox."+        "Note: when using a sandbox, all packages are required to have "+        ++ "consistent dependencies. Try reinstalling/unregistering the "+        ++ "offending packages or recreating the sandbox."       logMsg message rest = debugNoWrap verbosity message >> rest        topHandler' = topHandlerWith $ \_ -> do@@ -694,8 +772,8 @@     toSourcePackage (path, pkgDesc) = SourcePackage       (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing --- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op--- otherwise.+-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and the+-- identity otherwise. maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags                                -> Compiler -> Platform -> ProgramConfiguration                                -> UseSandbox@@ -791,3 +869,18 @@   configCompilerAuxEx configFlags     --FIXME: make configCompilerAux use a sensible verbosity     { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }++-- | Try to read the most recently configured compiler from the+-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it+-- cannot be read.+getPersistOrConfigCompiler :: ConfigFlags+                           -> IO (Compiler, Platform, ProgramConfiguration)+getPersistOrConfigCompiler configFlags = do+  distPref <- findDistPrefOrDefault (configDistPref configFlags)+  mlbi <- maybeGetPersistBuildConfig distPref+  case mlbi of+    Nothing  -> do configCompilerAux' configFlags+    Just lbi -> return ( LocalBuildInfo.compiler lbi+                       , LocalBuildInfo.hostPlatform lbi+                       , LocalBuildInfo.withPrograms lbi+                       )
cabal/cabal-install/Distribution/Client/Sandbox/Index.hs view
@@ -12,42 +12,44 @@     addBuildTreeRefs,     removeBuildTreeRefs,     ListIgnoredBuildTreeRefs(..), RefTypesToList(..),+    DeleteSourceError(..),     listBuildTreeRefs,     validateIndexPath,      defaultIndexFileName   ) where +import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils ( BuildTreeRefType(..)                                       , refTypeFromTypeCode                                       , typeCodeFromRefType                                       , updatePackageIndexCacheFile-                                      , getSourcePackagesStrict )-import Distribution.Client.PackageIndex ( allPackages )-import Distribution.Client.Types ( Repo(..), LocalRepo(..)-                                 , SourcePackageDb(..)-                                 , SourcePackage(..), PackageLocation(..) )+                                      , readCacheStrict+                                      , Index(..) )+import qualified Distribution.Client.IndexUtils as IndexUtils import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString                                  , makeAbsoluteToCwd, tryCanonicalizePath-                                 , canonicalizePathNoThrow                                  , tryFindAddSourcePackageDesc  )  import Distribution.Simple.Utils ( die, debug )+import Distribution.Compat.Exception   ( tryIO ) import Distribution.Verbosity    ( Verbosity )  import qualified Data.ByteString.Lazy as BS-import Control.Exception         ( evaluate )+import Control.Exception         ( evaluate, throw, Exception ) import Control.Monad             ( liftM, unless )-import Data.List                 ( (\\), intersect, nub )-import Data.Maybe                ( catMaybes )+import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)+import Data.List                 ( (\\), intersect, nub, find )+import Data.Maybe                ( catMaybes, fromMaybe )+import Data.Either               (partitionEithers) import System.Directory          ( createDirectoryIfMissing,                                    doesDirectoryExist, doesFileExist,-                                   renameFile )-import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension-                                 , replaceExtension )-import System.IO                 ( IOMode(..), SeekMode(..)-                                 , hSeek, withBinaryFile )+                                   renameFile, canonicalizePath)+import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )+import System.IO                 ( IOMode(..), withBinaryFile )  -- | A reference to a local build tree. data BuildTreeRef = BuildTreeRef {@@ -80,16 +82,27 @@  -- | Given a sequence of tar archive entries, extract all references to local -- build trees.-readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef]+readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef] readBuildTreeRefs =   catMaybes-  . Tar.foldrEntries (\e r -> readBuildTreeRef e : r)-  [] error+  . Tar.foldEntries (\e r -> readBuildTreeRef e : r)+                    [] throw  -- | Given a path to a tar archive, extract all references to local build trees. readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef] readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile +-- | Read build tree references from an index cache+readBuildTreeRefsFromCache :: Verbosity -> FilePath -> IO [BuildTreeRef]+readBuildTreeRefsFromCache verbosity indexPath = do+    (mRefs, _prefs) <- readCacheStrict verbosity (SandboxIndex indexPath) buildTreeRef+    return (catMaybes mRefs)+  where+    buildTreeRef pkgEntry =+      case pkgEntry of+         IndexUtils.NormalPackage _ _ _ _ -> Nothing+         IndexUtils.BuildTreeRef typ _ _ path _ -> Just $ BuildTreeRef typ path+ -- | Given a local build tree ref, serialise it to a tar archive entry. writeBuildTreeRef :: BuildTreeRef -> Tar.Entry writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content@@ -143,45 +156,76 @@   treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)   let entries = map writeBuildTreeRef (catMaybes treesToAdd)   unless (null entries) $ do-    offset <--      fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error-            . Tar.read) $ BS.readFile path-    _ <- evaluate offset-    debug verbosity $ "Writing at offset: " ++ show offset     withBinaryFile path ReadWriteMode $ \h -> do-      hSeek h AbsoluteSeek (fromIntegral offset)+      block <- Tar.hSeekEndEntryOffset h Nothing+      debug verbosity $ "Writing at tar block: " ++ show block       BS.hPut h (Tar.write entries)       debug verbosity $ "Successfully appended to '" ++ path ++ "'"-    updatePackageIndexCacheFile verbosity path-      (path `replaceExtension` "cache")+    updatePackageIndexCacheFile verbosity $ SandboxIndex path +data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }+                       | ErrNonexistentSource   { nePath :: FilePath } deriving Show+ -- | Remove given local build tree references from the index.-removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]+--+-- Returns a tuple with either removed build tree refs or errors and a function+-- that converts from a provided build tree ref to corresponding full directory path.+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath]+                       -> IO ([Either DeleteSourceError FilePath],+                              (FilePath -> FilePath)) removeBuildTreeRefs _         _   [] =   error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"-removeBuildTreeRefs verbosity path l' = do-  checkIndexExists path-  l <- mapM canonicalizePathNoThrow l'-  let tmpFile = path <.> "tmp"+removeBuildTreeRefs verbosity indexPath l = do+  checkIndexExists indexPath+  let tmpFile = indexPath <.> "tmp"++  canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr+                               return $ case res of+                                 Right pth -> Right (btr, pth)+                                 Left _ -> Left $ ErrNonexistentSource btr) l+  let (failures, convDict) = partitionEithers canonRes+      allRefs = fmap snd convDict+   -- Performance note: on my system, it takes 'index --remove-source'   -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be   -- much smaller.-  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read-    =<< BS.readFile path-  renameFile tmpFile path+  removedRefs <- doRemove convDict tmpFile++  renameFile tmpFile indexPath   debug verbosity $ "Successfully renamed '" ++ tmpFile-    ++ "' to '" ++ path ++ "'"-  updatePackageIndexCacheFile verbosity path (path `replaceExtension` "cache")-  -- FIXME: return only the refs that vere actually removed.-  return l+    ++ "' to '" ++ indexPath ++ "'"++  unless (null removedRefs) $+    updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath++  let results = fmap Right removedRefs+                ++ fmap Left failures+                ++ fmap (Left . ErrNonregisteredSource)+                        (fmap (convertWith convDict) (allRefs \\ removedRefs))++  return (results, convertWith convDict)+     where-      p l entry = case readBuildTreeRef entry of-        Nothing                     -> True+      doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath]+      doRemove srcRefs tmpFile = do+        (newIdx, changedPaths) <-+          Tar.read `fmap` BS.readFile indexPath+          >>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs)+        BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx+        return changedPaths++      p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool+      p refs entry = case readBuildTreeRef entry of+        Nothing -> return True         -- FIXME: removing snapshot deps is done with `delete-source         -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to         -- support removing snapshots by providing the original path.-        (Just (BuildTreeRef _ pth)) -> pth `notElem` l+        (Just (BuildTreeRef _ pth)) -> if pth `elem` refs+                                       then tell [pth] >> return False+                                       else return True +      convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict+ -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user -- runs 'cabal sandbox list-sources', but do not look at their timestamps in@@ -222,16 +266,11 @@         LinksAndSnapshots -> const True        listWithIgnored :: IO [BuildTreeRef]-      listWithIgnored = readBuildTreeRefsFromFile $ path+      listWithIgnored = readBuildTreeRefsFromFile path        listWithoutIgnored :: IO [FilePath]-      listWithoutIgnored = do-        let repo = Repo { repoKind = Right LocalRepo-                        , repoLocalDir = takeDirectory path }-        pkgIndex <- fmap packageIndex-                    . getSourcePackagesStrict verbosity $ [repo]-        return [ pkgPath | (LocalUnpackedPackage pkgPath) <--                    map packageSource . allPackages $ pkgIndex ]+      listWithoutIgnored = fmap (map buildTreePath)+                         $ readBuildTreeRefsFromCache verbosity path   -- | Check that the package index file exists and exit with error if it does not.
cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Sandbox.PackageEnvironment@@ -61,10 +62,8 @@ import Control.Monad                   ( foldM, liftM2, when, unless ) import Data.List                       ( partition ) import Data.Maybe                      ( isJust )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid                     ( Monoid(..) )-#endif import Distribution.Compat.Exception   ( catchIO )+import Distribution.Compat.Semigroup import System.Directory                ( doesDirectoryExist, doesFileExist                                        , renameFile ) import System.FilePath                 ( (<.>), (</>), takeDirectory )@@ -75,6 +74,7 @@ import qualified Distribution.Compat.ReadP as Parse import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) ) import qualified Distribution.Text         as Text+import GHC.Generics ( Generic )   --@@ -88,20 +88,14 @@   -- for constructing nested sandboxes (see discussion in #1196).   pkgEnvInherit       :: Flag FilePath,   pkgEnvSavedConfig   :: SavedConfig-}+} deriving Generic  instance Monoid PackageEnvironment where-  mempty = PackageEnvironment {-    pkgEnvInherit       = mempty,-    pkgEnvSavedConfig   = mempty-    }+  mempty = gmempty+  mappend = (<>) -  mappend a b = PackageEnvironment {-    pkgEnvInherit       = combine pkgEnvInherit,-    pkgEnvSavedConfig   = combine pkgEnvSavedConfig-    }-    where-      combine f = f a `mappend` f b+instance Semigroup PackageEnvironment where+  (<>) = gmappend  -- | The automatically-created package environment file that should not be -- touched by the user.@@ -280,27 +274,30 @@       return $ mempty { pkgEnvSavedConfig = conf }  -- | Load the user package environment if it exists (the optional "cabal.config"--- file).-userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment-userPackageEnvironment verbosity pkgEnvDir = do-  let path = pkgEnvDir </> userPackageEnvironmentFile-  minp <- readPackageEnvironmentFile ConstraintSourceUserConfig mempty path-  case minp of-    Nothing -> return mempty-    Just (ParseOk warns parseResult) -> do+-- file). If it does not exist locally, attempt to load an optional global one.+userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment+userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do+    let path = pkgEnvDir </> userPackageEnvironmentFile+    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) mempty path+    case (minp, globalConfigLocation) of+      (Just parseRes, _)  -> processConfigParse path parseRes+      (_, Just globalLoc) -> maybe (warn verbosity ("no constraints file found at " ++ globalLoc) >> return mempty) (processConfigParse globalLoc) =<< readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) mempty globalLoc+      _ -> return mempty+  where+    processConfigParse path (ParseOk warns parseResult) = do       when (not $ null warns) $ warn verbosity $         unlines (map (showPWarning path) warns)       return parseResult-    Just (ParseFailed err) -> do+    processConfigParse path (ParseFailed err) = do       let (line, msg) = locatedErrorMsg err-      warn verbosity $ "Error parsing user package environment file " ++ path+      warn verbosity $ "Error parsing package environment file " ++ path         ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg       return mempty  -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.-loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig-loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig-                                     $ userPackageEnvironment verbosity pkgEnvDir+loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig+loadUserConfig verbosity pkgEnvDir globalConfigLocation =+    fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation  -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'.@@ -347,7 +344,7 @@    let base   = basePackageEnvironment   let common = commonPackageEnvironment sandboxDir-  user      <- userPackageEnvironment verbosity pkgEnvDir+  user      <- userPackageEnvironment verbosity pkgEnvDir Nothing --TODO   inherited <- inheritedPackageEnvironment verbosity user    -- Layer the package environment settings over settings from ~/.cabal/config.@@ -400,7 +397,6 @@     (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)     pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v }) -    -- FIXME: Should we make these fields part of ~/.cabal/config ?   , commaNewLineListField "constraints"     (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse)     (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)
cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs view
@@ -10,10 +10,15 @@ module Distribution.Client.Sandbox.Timestamp (   AddSourceTimestamp,   withAddTimestamps,-  withRemoveTimestamps,   withUpdateTimestamps,   maybeAddCompilerTimestampRecord,   listModifiedDeps,+  removeTimestamps,++  -- * For testing+  TimestampFileRecord,+  readTimestampFile,+  writeTimestampFile   ) where  import Control.Exception                             (IOException)@@ -50,12 +55,13 @@   (inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc)  import Distribution.Compat.Exception                 (catchIO)-import Distribution.Client.Compat.Time               (EpochTime, getCurTime,-                                                      getModTime)+import Distribution.Client.Compat.Time               (ModTime, getCurTime,+                                                      getModTime,+                                                      posixSecondsToModTime)   -- | Timestamp of an add-source dependency.-type AddSourceTimestamp  = (FilePath, EpochTime)+type AddSourceTimestamp  = (FilePath, ModTime) -- | Timestamp file record - a string identifying the compiler & platform plus a -- list of add-source timestamps. type TimestampFileRecord = (String, [AddSourceTimestamp])@@ -79,15 +85,37 @@ readTimestampFile timestampFile = do   timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"   case reads timestampString of-    [(timestamps, s)] | all isSpace s -> return timestamps-    _                                 ->-      die $ "The timestamps file is corrupted. "-      ++ "Please delete & recreate the sandbox."+    [(version, s)]+      | version == (2::Int) ->+        case reads s of+          [(timestamps, s')] | all isSpace s' -> return timestamps+          _                                   -> dieCorrupted+      | otherwise   -> dieWrongFormat +    -- Old format (timestamps are POSIX seconds). Convert to new format.+    [] ->+      case reads timestampString of+        [(timestamps, s)] | all isSpace s -> do+          let timestamps' = map (\(i, ts) ->+                                  (i, map (\(p, t) ->+                                            (p, posixSecondsToModTime t)) ts))+                            timestamps+          writeTimestampFile timestampFile timestamps'+          return timestamps'+        _ -> dieCorrupted+    _ -> dieCorrupted+  where+    dieWrongFormat    = die $ wrongFormat ++ deleteAndRecreate+    dieCorrupted      = die $ corrupted ++ deleteAndRecreate+    wrongFormat       = "The timestamps file is in the wrong format."+    corrupted         = "The timestamps file is corrupted."+    deleteAndRecreate = " Please delete and recreate the sandbox."+ -- | Write the timestamp file, atomically. writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO () writeTimestampFile timestampFile timestamps = do-  writeFile  timestampTmpFile (show timestamps)+  writeFile  timestampTmpFile "2\n" -- version+  appendFile timestampTmpFile (show timestamps ++ "\n")   renameFile timestampTmpFile timestampFile   where     timestampTmpFile = timestampFile <.> "tmp"@@ -105,7 +133,7 @@ -- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list -- for each path. If a timestamp for a given path already exists in the list, -- update it.-addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]+addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]                  -> [AddSourceTimestamp] addTimestamps initial timestamps newPaths =   [ (p, initial) | p <- newPaths ] ++ oldTimestamps@@ -116,7 +144,7 @@ -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps -- we've reinstalled and a new timestamp value, update the timestamp value for -- the deps in the list. If there are new paths in the list, ignore them.-updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime+updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime                     -> [AddSourceTimestamp] updateTimestamps timestamps pathsToUpdate newTimestamp =   foldr updateTimestamp [] timestamps@@ -127,8 +155,8 @@  -- | Given a list of 'TimestampFileRecord's and a list of paths to add-source -- deps we've removed, remove those deps from the list.-removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]-removeTimestamps l pathsToRemove = foldr removeTimestamp [] l+removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]+removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l   where     removeTimestamp t@(path, _oldTimestamp) rest =       if path `elem` pathsToRemove@@ -156,13 +184,14 @@ -- build tree refs to the timestamps file (for all compilers). withAddTimestamps :: FilePath -> IO [FilePath] -> IO () withAddTimestamps sandboxDir act = do-  let initialTimestamp = 0+  let initialTimestamp = minBound   withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act --- | Given an IO action that returns a list of build tree refs, remove those+-- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers).-withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO ()-withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps+removeTimestamps :: FilePath -> [FilePath] -> IO ()+removeTimestamps idxFile =+  withActionOnAllTimestamps removeTimestamps' idxFile . return  -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the@@ -191,7 +220,7 @@ -- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result -- and then updates the timestamp file record. The IO action is run only once. withActionOnCompilerTimestamps :: ([AddSourceTimestamp]-                                   -> [FilePath] -> EpochTime+                                   -> [FilePath] -> ModTime                                    -> [AddSourceTimestamp])                                   -> FilePath                                   -> CompilerId@@ -249,7 +278,7 @@   return ret  -- | Has this dependency been modified since we have last looked at it?-isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool+isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool isDepModified verbosity now (packageDir, timestamp) = do   debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)   depSources <- allPackageSourceFiles verbosity packageDir
cabal/cabal-install/Distribution/Client/Sandbox/Types.hs view
@@ -14,10 +14,11 @@   ) where  import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import Distribution.Client.Types (SourcePackage)+import Distribution.Client.Types (UnresolvedSourcePackage)+import Distribution.Compat.Semigroup (Semigroup((<>)))  #if !MIN_VERSION_base(4,8,0)-import Data.Monoid+import Data.Monoid (Monoid(..)) #endif import qualified Data.Set as S @@ -26,10 +27,12 @@  instance Monoid UseSandbox where   mempty = NoSandbox+  mappend = (<>) -  NoSandbox        `mappend` s                  = s-  u0@(UseSandbox _) `mappend` NoSandbox         = u0-  (UseSandbox   _)  `mappend` u1@(UseSandbox _) = u1+instance Semigroup UseSandbox where+  NoSandbox         <> s                 = s+  u0@(UseSandbox _) <> NoSandbox         = u0+  (UseSandbox _)    <> u1@(UseSandbox _) = u1  -- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with -- @when@.@@ -46,11 +49,11 @@ -- | Data about the packages installed in the sandbox that is passed from -- 'reinstallAddSourceDeps' to the solver. data SandboxPackageInfo = SandboxPackageInfo {-  modifiedAddSourceDependencies :: ![SourcePackage],+  modifiedAddSourceDependencies :: ![UnresolvedSourcePackage],   -- ^ Modified add-source deps that we want to reinstall. These are guaranteed   -- to be already installed in the sandbox. -  otherAddSourceDependencies    :: ![SourcePackage],+  otherAddSourceDependencies    :: ![UnresolvedSourcePackage],   -- ^ Remaining add-source deps. Some of these may be not installed in the   -- sandbox.
+ cabal/cabal-install/Distribution/Client/Security/HTTP.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'+module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where++-- stdlibs+import Control.Exception+         ( Exception(..), IOException )+import Data.List+         ( intercalate )+import Data.Typeable+         ( Typeable )+import System.Directory+         ( getTemporaryDirectory )+import Network.URI+         ( URI )+import qualified Data.ByteString.Lazy as BS.L+import qualified Network.HTTP         as HTTP++-- Cabal/cabal-install+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Client.HttpUtils+         ( HttpTransport(..), HttpCode )+import Distribution.Client.Utils+         ( withTempFileName )++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Util.Lens as Lens++{-------------------------------------------------------------------------------+  'HttpLib' implementation+-------------------------------------------------------------------------------}++-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'+--+-- NOTE: The match between these two APIs is currently not perfect:+--+-- * We don't get any response headers back from the 'HttpTransport', so we+--   don't know if the server supports range requests. For now we optimistically+--   assume that it does.+-- * The 'HttpTransport' wants to know where to place the resulting file,+--   whereas the 'HttpLib' expects an 'IO' action which streams the download;+--   the security library then makes sure that the file gets written to a+--   location which is suitable (in particular, to a temporary file in the+--   directory where the file needs to end up, so that it can "finalize" the+--   file simply by doing 'renameFile'). Right now we write the file to a+--   temporary file in the system temp directory here and then read it again+--   to pass it to the security library; this is a problem for two reasons: it+--   is a source of inefficiency; and it means that the security library cannot+--   insist on a minimum download rate (potential security attack).+--   Fixing it however would require changing the 'HttpTransport'.+transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib+transportAdapter verbosity getTransport = HttpLib{+      httpGet      = \headers uri callback -> do+                        transport <- getTransport+                        get verbosity transport headers uri callback+    , httpGetRange = \headers uri range callback -> do+                        transport <- getTransport+                        getRange verbosity transport headers uri range callback+    }++get :: Throws SomeRemoteError+    => Verbosity+    -> HttpTransport+    -> [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get verbosity transport reqHeaders uri callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->+    case code of+      200 -> callback respHeaders br+      _   -> throwChecked $ UnexpectedResponse uri code++getRange :: Throws SomeRemoteError+         => Verbosity+         -> HttpTransport+         -> [HttpRequestHeader] -> URI -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->+    case code of+       200 -> callback HttpStatus200OK             respHeaders br+       206 -> callback HttpStatus206PartialContent respHeaders br+       _   -> throwChecked $ UnexpectedResponse uri code++-- | Internal generalization of 'get' and 'getRange'+get' :: Verbosity+     -> HttpTransport+     -> [HttpRequestHeader] -> URI -> Maybe (Int, Int)+     -> (HttpCode -> [HttpResponseHeader] -> BodyReader -> IO a)+     -> IO a+get' verbosity transport reqHeaders uri mRange callback = do+    tempDir <- getTemporaryDirectory+    withTempFileName tempDir "transportAdapterGet" $ \temp -> do+      (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'+      br <- bodyReaderFromBS =<< BS.L.readFile temp+      callback code [HttpResponseAcceptRangesBytes] br+  where+    reqHeaders' = mkReqHeaders reqHeaders mRange++{-------------------------------------------------------------------------------+  Request headers+-------------------------------------------------------------------------------}++mkRangeHeader :: Int -> Int -> HTTP.Header+mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)++mkReqHeaders :: [HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]+mkReqHeaders reqHeaders mRange = concat [+      tr [] reqHeaders+    , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]+    ]+  where+    tr :: [(HTTP.HeaderName, [String])] -> [HttpRequestHeader] -> [HTTP.Header]+    tr acc [] =+      concatMap finalize acc+    tr acc (HttpRequestMaxAge0:os) =+      tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os+    tr acc (HttpRequestNoTransform:os) =+      tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we we just comma-separate all of them.+    finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]+    finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = Lens.modify (Lens.lookupM x) (++ y)++{-------------------------------------------------------------------------------+  Custom exceptions+-------------------------------------------------------------------------------}++data UnexpectedResponse = UnexpectedResponse URI Int+  deriving (Typeable)++instance Pretty UnexpectedResponse where+  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code+                                      ++ "for " ++ show uri++#if MIN_VERSION_base(4,8,0)+deriving instance Show UnexpectedResponse+instance Exception UnexpectedResponse where displayException = pretty+#else+instance Show UnexpectedResponse where show = pretty+instance Exception UnexpectedResponse+#endif++wrapCustomEx :: ( ( Throws UnexpectedResponse+                  , Throws IOException+                  ) => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ handleChecked (\(ex :: IOException)        -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)
cabal/cabal-install/Distribution/Client/Setup.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Setup@@ -12,13 +15,15 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos+    ( globalCommand, GlobalFlags(..), defaultGlobalFlags+    , RepoContext(..), withRepoContext     , configureCommand, ConfigFlags(..), filterConfigureFlags     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions     , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)     , replCommand, testCommand, benchmarkCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , defaultSolver, defaultMaxBackjumps     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand@@ -26,6 +31,7 @@     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)     , freezeCommand, FreezeFlags(..)+    , genBoundsCommand     , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , formatCommand@@ -39,6 +45,7 @@     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)     , execCommand, ExecFlags(..)     , userConfigCommand, UserConfigFlags(..)+    , manpageCommand      , parsePackageArgs     --TODO: stop exporting these:@@ -48,11 +55,11 @@     ) where  import Distribution.Client.Types-         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )+         ( Username(..), Password(..), RemoteRepo(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( AllowNewer(..), PreSolver(..), ConstraintSource(..) )+         ( PreSolver(..), ConstraintSource(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets@@ -60,6 +67,7 @@ import Distribution.Utils.NubList          ( NubList, toNubList, fromNubList) + import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program          ( defaultProgramConfiguration )@@ -71,8 +79,9 @@          , TestFlags(..), BenchmarkFlags(..)          , SDistFlags(..), HaddockFlags(..)          , readPackageDbList, showPackageDbList-         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs )+         , Flag(..), toFlag, flagToMaybe, flagToList+         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg+         , readPToMaybe, optionNumJobs ) import Distribution.Simple.InstallDirs          ( PathTemplate, InstallDirs(sysconfdir)          , toPathTemplate, fromPathTemplate )@@ -87,22 +96,25 @@ import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) )+         ( ReadP, char, munch1, pfail,  (+++) )+import Distribution.Compat.Semigroup import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils          ( wrapText, wrapLine )+import Distribution.Client.GlobalFlags+         ( GlobalFlags(..), defaultGlobalFlags+         , RepoContext(..), withRepoContext+         )  import Data.Char-         ( isSpace, isAlphaNum )+         ( isAlphaNum ) import Data.List          ( intercalate, deleteFirstsBy ) import Data.Maybe-         ( listToMaybe, maybeToList, fromMaybe )-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-         ( Monoid(..) )-#endif+         ( maybeToList, fromMaybe )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary) import Control.Monad          ( liftM ) import System.FilePath@@ -110,42 +122,6 @@ import Network.URI          ( parseAbsoluteURI, uriToString ) --- --------------------------------------------------------------- * Global flags--- ---------------------------------------------------------------- | Flags that apply at the top level, not to any sub-command.-data GlobalFlags = GlobalFlags {-    globalVersion           :: Flag Bool,-    globalNumericVersion    :: Flag Bool,-    globalConfigFile        :: Flag FilePath,-    globalSandboxConfigFile :: Flag FilePath,-    globalRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.-    globalCacheDir          :: Flag FilePath,-    globalLocalRepos        :: NubList FilePath,-    globalLogsDir           :: Flag FilePath,-    globalWorldFile         :: Flag FilePath,-    globalRequireSandbox    :: Flag Bool,-    globalIgnoreSandbox     :: Flag Bool,-    globalHttpTransport     :: Flag String-  }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion           = Flag False,-    globalNumericVersion    = Flag False,-    globalConfigFile        = mempty,-    globalSandboxConfigFile = mempty,-    globalRemoteRepos       = mempty,-    globalCacheDir          = mempty,-    globalLocalRepos        = mempty,-    globalLogsDir           = mempty,-    globalWorldFile         = mempty,-    globalRequireSandbox    = Flag False,-    globalIgnoreSandbox     = Flag False,-    globalHttpTransport     = mempty-  }- globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI {     commandName         = "",@@ -187,6 +163,7 @@           , "upload"           , "report"           , "freeze"+          , "gen-bounds"           , "haddock"           , "hscolour"           , "copy"@@ -237,6 +214,7 @@         , addCmd "report"         , par         , addCmd "freeze"+        , addCmd "gen-bounds"         , addCmd "haddock"         , addCmd "hscolour"         , addCmd "copy"@@ -261,9 +239,17 @@       ++ "  " ++ pname ++ " update\n",     commandNotes = Nothing,     commandDefaultFlags = mempty,-    commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 7; ParseArgs -> id)-      [option ['V'] ["version"]+    commandOptions = args+  }+  where+    args :: ShowOrParseArgs -> [OptionField GlobalFlags]+    args ShowArgs  = argsShown+    args ParseArgs = argsShown ++ argsNotShown++    -- arguments we want to show in the help+    argsShown :: [OptionField GlobalFlags]+    argsShown = [+       option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })          trueArg@@ -280,9 +266,14 @@        ,option [] ["sandbox-config-file"]          "Set an alternate location for the sandbox config file (default: './cabal.sandbox.config')"-         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })+         globalSandboxConfigFile (\v flags -> flags { globalSandboxConfigFile = v })          (reqArgFlag "FILE") +      ,option [] ["default-user-config"]+         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."+         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})+         (reqArgFlag "FILE")+       ,option [] ["require-sandbox"]          "requiring the presence of a sandbox for sandbox-aware commands"          globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })@@ -293,12 +284,21 @@          globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })          trueArg +      ,option [] ["ignore-expiry"]+         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"+         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })+         trueArg+       ,option [] ["http-transport"]          "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"-         globalConfigFile (\v flags -> flags { globalHttpTransport = v })+         globalHttpTransport (\v flags -> flags { globalHttpTransport = v })          (reqArgFlag "HttpTransport")+      ] -      ,option [] ["remote-repo"]+    -- arguments we don't want shown in the help+    argsNotShown :: [OptionField GlobalFlags]+    argsNotShown = [+       option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })          (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))@@ -323,51 +323,7 @@          globalWorldFile (\v flags -> flags { globalWorldFile = v })          (reqArgFlag "FILE")       ]-  } -instance Monoid GlobalFlags where-  mempty = GlobalFlags {-    globalVersion           = mempty,-    globalNumericVersion    = mempty,-    globalConfigFile        = mempty,-    globalSandboxConfigFile = mempty,-    globalRemoteRepos       = mempty,-    globalCacheDir          = mempty,-    globalLocalRepos        = mempty,-    globalLogsDir           = mempty,-    globalWorldFile         = mempty,-    globalRequireSandbox    = mempty,-    globalIgnoreSandbox     = mempty,-    globalHttpTransport     = mempty-  }-  mappend a b = GlobalFlags {-    globalVersion           = combine globalVersion,-    globalNumericVersion    = combine globalNumericVersion,-    globalConfigFile        = combine globalConfigFile,-    globalSandboxConfigFile = combine globalConfigFile,-    globalRemoteRepos       = combine globalRemoteRepos,-    globalCacheDir          = combine globalCacheDir,-    globalLocalRepos        = combine globalLocalRepos,-    globalLogsDir           = combine globalLogsDir,-    globalWorldFile         = combine globalWorldFile,-    globalRequireSandbox    = combine globalRequireSandbox,-    globalIgnoreSandbox     = combine globalIgnoreSandbox,-    globalHttpTransport     = combine globalHttpTransport-  }-    where combine field = field a `mappend` field b--globalRepos :: GlobalFlags -> [Repo]-globalRepos globalFlags = remoteRepos ++ localRepos-  where-    remoteRepos =-      [ Repo (Left remote) cacheDir-      | remote <- fromNubList $ globalRemoteRepos globalFlags-      , let cacheDir = fromFlag (globalCacheDir globalFlags)-                   </> remoteRepoName remote ]-    localRepos =-      [ Repo (Right LocalRepo) local-      | local <- fromNubList $ globalLocalRepos globalFlags ]- -- ------------------------------------------------------------ -- * Config flags -- ------------------------------------------------------------@@ -397,6 +353,7 @@   -- ^ NB: we expect the latest version to be the most common case.   | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10   | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0+  | cabalLibVersion <  Version [1,12,0] [] = flags_1_12_0   | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0   | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0   | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0@@ -406,12 +363,18 @@   | cabalLibVersion <  Version [1,23,0] [] = flags_1_22_0   | otherwise = flags_latest   where-    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.-    flags_latest = flags        { configConstraints = [] }+    flags_latest = flags        {+      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.+      configConstraints = [],+      -- Passing '--allow-newer' to Setup.hs is unnecessary, we use+      -- '--exact-configuration' instead.+      configAllowNewer  = Just Cabal.AllowNewerNone+      }      -- Cabal < 1.23 doesn't know about '--profiling-detail'.     flags_1_22_0 = flags_latest { configProfDetail    = NoFlag-                                , configProfLibDetail = NoFlag }+                                , configProfLibDetail = NoFlag+                                , configIPID          = NoFlag }      -- Cabal < 1.22 doesn't know about '--disable-debug-info'.     flags_1_21_0 = flags_1_22_0 { configDebugInfo = NoFlag }@@ -440,8 +403,12 @@     configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }     -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.     flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }+    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'+    -- and '--enable/disable-library-coverage'.+    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag+                                , configDynExe      = NoFlag }     -- Cabal < 1.10.0 doesn't know about '--disable-tests'.-    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }+    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }     -- Cabal < 1.3.10 does not grok the '--constraints' flag.     flags_1_3_10 = flags_1_10_0 { configConstraints = [] } @@ -455,13 +422,12 @@     configCabalVersion :: Flag Version,     configExConstraints:: [(UserConstraint, ConstraintSource)],     configPreferences  :: [Dependency],-    configSolver       :: Flag PreSolver,-    configAllowNewer   :: Flag AllowNewer+    configSolver       :: Flag PreSolver   }+  deriving (Eq, Generic)  defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver-                              , configAllowNewer = Flag AllowNewerNone }+defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }  configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand {@@ -505,33 +471,15 @@    , optionSolver configSolver (\v flags -> flags { configSolver = v }) -  , option [] ["allow-newer"]-    ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument)-    configAllowNewer (\v flags -> flags { configAllowNewer = v})-    (optArg allowNewerArgument-     (fmap Flag allowNewerParser) (Flag AllowNewerAll)-     allowNewerPrinter)-   ]-  where allowNewerArgument = "DEPS"  instance Monoid ConfigExFlags where-  mempty = ConfigExFlags {-    configCabalVersion = mempty,-    configExConstraints= mempty,-    configPreferences  = mempty,-    configSolver       = mempty,-    configAllowNewer   = mempty-  }-  mappend a b = ConfigExFlags {-    configCabalVersion = combine configCabalVersion,-    configExConstraints= combine configExConstraints,-    configPreferences  = combine configPreferences,-    configSolver       = combine configSolver,-    configAllowNewer   = combine configAllowNewer-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ConfigExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------@@ -542,7 +490,7 @@  data BuildExFlags = BuildExFlags {   buildOnly     :: Flag SkipAddSourceDepsCheck-}+} deriving Generic  buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags] buildExOptions _showOrParseArgs =@@ -569,14 +517,12 @@     parent = Cabal.buildCommand defaultProgramConfiguration  instance Monoid BuildExFlags where-  mempty = BuildExFlags {-    buildOnly    = mempty-  }-  mappend a b = BuildExFlags {-    buildOnly    = combine buildOnly-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup BuildExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Repl command -- ------------------------------------------------------------@@ -799,6 +745,22 @@    } +genBoundsCommand :: CommandUI FreezeFlags+genBoundsCommand = CommandUI {+    commandName         = "gen-bounds",+    commandSynopsis     = "Generate dependency bounds.",+    commandDescription  = Just $ \_ -> wrapText $+         "Generates bounds for all dependencies that do not currently have them. "+      ++ "Generated bounds are printed to stdout.  You can then paste them into your .cabal file.\n"+      ++ "\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "gen-bounds",+    commandDefaultFlags = defaultFreezeFlags,+    commandOptions      = \ _ -> [+     optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })+     ]+  }+ -- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------@@ -877,6 +839,18 @@     commandOptions      = \_ -> []   } +manpageCommand :: CommandUI (Flag Verbosity)+manpageCommand = CommandUI {+    commandName         = "manpage",+    commandSynopsis     = "Outputs manpage source.",+    commandDescription  = Just $ \_ ->+      "Output manpage source to STDOUT.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "manpage",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }+ runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI {     commandName         = "run",@@ -918,7 +892,7 @@     reportUsername  :: Flag Username,     reportPassword  :: Flag Password,     reportVerbosity :: Flag Verbosity-  }+  } deriving Generic  defaultReportFlags :: ReportFlags defaultReportFlags = ReportFlags {@@ -954,18 +928,12 @@   }  instance Monoid ReportFlags where-  mempty = ReportFlags {-    reportUsername  = mempty,-    reportPassword  = mempty,-    reportVerbosity = mempty-  }-  mappend a b = ReportFlags {-    reportUsername  = combine reportUsername,-    reportPassword  = combine reportPassword,-    reportVerbosity = combine reportVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ReportFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Get flags -- ------------------------------------------------------------@@ -975,7 +943,7 @@     getPristine         :: Flag Bool,     getSourceRepository :: Flag (Maybe RepoKind),     getVerbosity        :: Flag Verbosity-  }+  } deriving Generic  defaultGetFlags :: GetFlags defaultGetFlags = GetFlags {@@ -1034,20 +1002,12 @@   }  instance Monoid GetFlags where-  mempty = GetFlags {-    getDestDir          = mempty,-    getPristine         = mempty,-    getSourceRepository = mempty,-    getVerbosity        = mempty-    }-  mappend a b = GetFlags {-    getDestDir          = combine getDestDir,-    getPristine         = combine getPristine,-    getSourceRepository = combine getSourceRepository,-    getVerbosity        = combine getVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup GetFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * List flags -- ------------------------------------------------------------@@ -1057,7 +1017,7 @@     listSimpleOutput :: Flag Bool,     listVerbosity    :: Flag Verbosity,     listPackageDBs   :: [Maybe PackageDB]-  }+  } deriving Generic  defaultListFlags :: ListFlags defaultListFlags = ListFlags {@@ -1113,20 +1073,12 @@   }  instance Monoid ListFlags where-  mempty = ListFlags {-    listInstalled    = mempty,-    listSimpleOutput = mempty,-    listVerbosity    = mempty,-    listPackageDBs   = mempty-    }-  mappend a b = ListFlags {-    listInstalled    = combine listInstalled,-    listSimpleOutput = combine listSimpleOutput,-    listVerbosity    = combine listVerbosity,-    listPackageDBs   = combine listPackageDBs-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ListFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Info flags -- ------------------------------------------------------------@@ -1134,7 +1086,7 @@ data InfoFlags = InfoFlags {     infoVerbosity  :: Flag Verbosity,     infoPackageDBs :: [Maybe PackageDB]-  }+  } deriving Generic  defaultInfoFlags :: InfoFlags defaultInfoFlags = InfoFlags {@@ -1171,16 +1123,12 @@   }  instance Monoid InfoFlags where-  mempty = InfoFlags {-    infoVerbosity  = mempty,-    infoPackageDBs = mempty-    }-  mappend a b = InfoFlags {-    infoVerbosity  = combine infoVerbosity,-    infoPackageDBs = combine infoPackageDBs-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup InfoFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Install flags -- ------------------------------------------------------------@@ -1213,7 +1161,10 @@     installRunTests         :: Flag Bool,     installOfflineMode      :: Flag Bool   }+  deriving (Eq, Generic) +instance Binary InstallFlags+ defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags {     installDocumentation   = Flag False,@@ -1245,27 +1196,6 @@     docIndexFile = toPathTemplate ("$datadir" </> "doc"                                    </> "$arch-$os-$compiler" </> "index.html") -allowNewerParser :: ReadE AllowNewer-allowNewerParser = ReadE $ \s ->-  case s of-    ""      -> Right AllowNewerNone-    "False" -> Right AllowNewerNone-    "True"  -> Right AllowNewerAll-    _       ->-      case readPToMaybe pkgsParser s of-        Just pkgs -> Right . AllowNewerSome $ pkgs-        Nothing   -> Left ("Cannot parse the list of packages: " ++ s)-  where-    pkgsParser = Parse.sepBy1 parse (Parse.char ',')--allowNewerPrinter :: Flag AllowNewer -> [Maybe String]-allowNewerPrinter (Flag AllowNewerNone)        = [Just "False"]-allowNewerPrinter (Flag AllowNewerAll)         = [Just "True"]-allowNewerPrinter (Flag (AllowNewerSome pkgs)) =-  [Just . intercalate "," . map display $ pkgs]-allowNewerPrinter NoFlag                       = []-- defaultMaxBackjumps :: Int defaultMaxBackjumps = 2000 @@ -1482,75 +1412,29 @@   instance Monoid InstallFlags where-  mempty = InstallFlags {-    installDocumentation   = mempty,-    installHaddockIndex    = mempty,-    installDryRun          = mempty,-    installReinstall       = mempty,-    installAvoidReinstalls = mempty,-    installOverrideReinstall = mempty,-    installMaxBackjumps    = mempty,-    installUpgradeDeps     = mempty,-    installReorderGoals    = mempty,-    installIndependentGoals= mempty,-    installShadowPkgs      = mempty,-    installStrongFlags     = mempty,-    installOnly            = mempty,-    installOnlyDeps        = mempty,-    installRootCmd         = mempty,-    installSummaryFile     = mempty,-    installLogFile         = mempty,-    installBuildReports    = mempty,-    installReportPlanningFailure = mempty,-    installSymlinkBinDir   = mempty,-    installOneShot         = mempty,-    installNumJobs         = mempty,-    installRunTests        = mempty,-    installOfflineMode     = mempty-  }-  mappend a b = InstallFlags {-    installDocumentation   = combine installDocumentation,-    installHaddockIndex    = combine installHaddockIndex,-    installDryRun          = combine installDryRun,-    installReinstall       = combine installReinstall,-    installAvoidReinstalls = combine installAvoidReinstalls,-    installOverrideReinstall = combine installOverrideReinstall,-    installMaxBackjumps    = combine installMaxBackjumps,-    installUpgradeDeps     = combine installUpgradeDeps,-    installReorderGoals    = combine installReorderGoals,-    installIndependentGoals= combine installIndependentGoals,-    installShadowPkgs      = combine installShadowPkgs,-    installStrongFlags     = combine installStrongFlags,-    installOnly            = combine installOnly,-    installOnlyDeps        = combine installOnlyDeps,-    installRootCmd         = combine installRootCmd,-    installSummaryFile     = combine installSummaryFile,-    installLogFile         = combine installLogFile,-    installBuildReports    = combine installBuildReports,-    installReportPlanningFailure = combine installReportPlanningFailure,-    installSymlinkBinDir   = combine installSymlinkBinDir,-    installOneShot         = combine installOneShot,-    installNumJobs         = combine installNumJobs,-    installRunTests        = combine installRunTests,-    installOfflineMode     = combine installOfflineMode-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup InstallFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Upload flags -- ------------------------------------------------------------  data UploadFlags = UploadFlags {     uploadCheck       :: Flag Bool,+    uploadDoc         :: Flag Bool,     uploadUsername    :: Flag Username,     uploadPassword    :: Flag Password,     uploadPasswordCmd :: Flag [String],     uploadVerbosity   :: Flag Verbosity-  }+  } deriving Generic  defaultUploadFlags :: UploadFlags defaultUploadFlags = UploadFlags {     uploadCheck       = toFlag False,+    uploadDoc         = toFlag False,     uploadUsername    = mempty,     uploadPassword    = mempty,     uploadPasswordCmd = mempty,@@ -1560,7 +1444,7 @@ uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI {     commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage.",+    commandSynopsis     = "Uploads source packages or documentation to Hackage.",     commandDescription  = Nothing,     commandNotes        = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n"@@ -1576,6 +1460,11 @@         uploadCheck (\v flags -> flags { uploadCheck = v })         trueArg +      ,option ['d'] ["documentation"]+        "Upload documentation instead of a source package. Cannot be used together with --check."+        uploadDoc (\v flags -> flags { uploadDoc = v })+        trueArg+       ,option ['u'] ["username"]         "Hackage username."         uploadUsername (\v flags -> flags { uploadUsername = v })@@ -1596,22 +1485,12 @@   }  instance Monoid UploadFlags where-  mempty = UploadFlags {-    uploadCheck       = mempty,-    uploadUsername    = mempty,-    uploadPassword    = mempty,-    uploadPasswordCmd = mempty,-    uploadVerbosity   = mempty-  }-  mappend a b = UploadFlags {-    uploadCheck       = combine uploadCheck,-    uploadUsername    = combine uploadUsername,-    uploadPassword    = combine uploadPassword,-    uploadPasswordCmd = combine uploadPasswordCmd,-    uploadVerbosity   = combine uploadVerbosity-  }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup UploadFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Init flags -- ------------------------------------------------------------@@ -1807,7 +1686,7 @@ data SDistExFlags = SDistExFlags {     sDistFormat    :: Flag ArchiveFormat   }-  deriving Show+  deriving (Show, Generic)  data ArchiveFormat = TargzFormat | ZipFormat -- | ...   deriving (Show, Eq)@@ -1840,22 +1719,19 @@       ]  instance Monoid SDistExFlags where-  mempty = SDistExFlags {-    sDistFormat  = mempty-  }-  mappend a b = SDistExFlags {-    sDistFormat  = combine sDistFormat-  }-    where-      combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup SDistExFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Win32SelfUpgrade flags -- ------------------------------------------------------------  data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags {   win32SelfUpgradeVerbosity :: Flag Verbosity-}+} deriving Generic  defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags {@@ -1878,21 +1754,19 @@ }  instance Monoid Win32SelfUpgradeFlags where-  mempty      = Win32SelfUpgradeFlags {-    win32SelfUpgradeVerbosity = mempty-    }-  mappend a b = Win32SelfUpgradeFlags {-    win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup Win32SelfUpgradeFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * ActAsSetup flags -- ------------------------------------------------------------  data ActAsSetupFlags = ActAsSetupFlags {     actAsSetupBuildType :: Flag BuildType-}+} deriving Generic  defaultActAsSetupFlags :: ActAsSetupFlags defaultActAsSetupFlags = ActAsSetupFlags {@@ -1919,14 +1793,12 @@ }  instance Monoid ActAsSetupFlags where-  mempty      = ActAsSetupFlags {-     actAsSetupBuildType = mempty-    }-  mappend a b = ActAsSetupFlags {-    actAsSetupBuildType = combine actAsSetupBuildType-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ActAsSetupFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Sandbox-related flags -- ------------------------------------------------------------@@ -1936,7 +1808,7 @@   sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only                                  -- flag.   sandboxLocation  :: Flag FilePath-}+} deriving Generic  defaultSandboxLocation :: FilePath defaultSandboxLocation = ".cabal-sandbox"@@ -2043,25 +1915,19 @@   }  instance Monoid SandboxFlags where-  mempty = SandboxFlags {-    sandboxVerbosity = mempty,-    sandboxSnapshot  = mempty,-    sandboxLocation  = mempty-    }-  mappend a b = SandboxFlags {-    sandboxVerbosity = combine sandboxVerbosity,-    sandboxSnapshot  = combine sandboxSnapshot,-    sandboxLocation  = combine sandboxLocation-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup SandboxFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * Exec Flags -- ------------------------------------------------------------  data ExecFlags = ExecFlags {   execVerbosity :: Flag Verbosity-}+} deriving Generic  defaultExecFlags :: ExecFlags defaultExecFlags = ExecFlags {@@ -2113,31 +1979,31 @@   }  instance Monoid ExecFlags where-  mempty = ExecFlags {-    execVerbosity = mempty-    }-  mappend a b = ExecFlags {-    execVerbosity = combine execVerbosity-    }-    where combine field = field a `mappend` field b+  mempty = gmempty+  mappend = (<>) +instance Semigroup ExecFlags where+  (<>) = gmappend+ -- ------------------------------------------------------------ -- * UserConfig flags -- ------------------------------------------------------------  data UserConfigFlags = UserConfigFlags {-  userConfigVerbosity :: Flag Verbosity-}+  userConfigVerbosity :: Flag Verbosity,+  userConfigForce     :: Flag Bool+} deriving Generic  instance Monoid UserConfigFlags where   mempty = UserConfigFlags {-    userConfigVerbosity = toFlag normal-    }-  mappend a b = UserConfigFlags {-    userConfigVerbosity = combine userConfigVerbosity+    userConfigVerbosity = toFlag normal,+    userConfigForce     = toFlag False     }-    where combine field = field a `mappend` field b+  mappend = (<>) +instance Semigroup UserConfigFlags where+  (<>) = gmappend+ userConfigCommand :: CommandUI UserConfigFlags userConfigCommand = CommandUI {   commandName         = "user-config",@@ -2149,6 +2015,9 @@     ++ " (i.e. all bindings that are actually defined and not commented out)"     ++ " and the default config of the new version.\n"     ++ "\n"+    ++ "init: Creates a new config file at either ~/.cabal/config or as"+    ++ " specified by --config-file, if given. An existing file won't be "+    ++ " overwritten unless -f or --force is given.\n"     ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and"     ++ " the default configuration that would be created by cabal if the"     ++ " config file did not exist.\n"@@ -2156,10 +2025,14 @@     ++ " created by default, and write the result back to ~/.cabal/config.",    commandNotes        = Nothing,-  commandUsage        = usageAlternatives "user-config" ["diff", "update"],+  commandUsage        = usageAlternatives "user-config" ["init", "diff", "update"],   commandDefaultFlags = mempty,   commandOptions      = \ _ -> [    optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })+ , option ['f'] ["force"]+     "Overwrite the config file if it already exists."+     userConfigForce (\v flags -> flags { userConfigForce = v })+     trueArg    ]   } @@ -2201,8 +2074,7 @@   [ option [] ["max-backjumps"]       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")       getmbj setmbj-      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++)-                                (fmap toFlag (Parse.readS_to_P reads)))+      (reqArg "NUM" (readP_to_E ("Cannot parse number: "++) (fmap toFlag parse))                     (map show . flagToList))   , option [] ["reorder-goals"]       "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."@@ -2250,10 +2122,6 @@          show arg ++ " is not valid syntax for a package name or"                   ++ " package dependency." -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                     , all isSpace s ]- parseDependencyOrPackageId :: Parse.ReadP r Dependency parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse   where@@ -2278,7 +2146,9 @@   return RemoteRepo {     remoteRepoName           = name,     remoteRepoURI            = uri,-    remoteRepoRootKeys       = (),+    remoteRepoSecure         = Nothing,+    remoteRepoRootKeys       = [],+    remoteRepoKeyThreshold   = 0,     remoteRepoShouldTryHttps = False   } @@ -2301,6 +2171,7 @@  indentParagraph :: String -> String indentParagraph = unlines+                . (flip (++)) [""]                 . map (("  "++).unwords)                 . wrapLine 77                 . words
cabal/cabal-install/Distribution/Client/SetupWrapper.hs view
@@ -27,9 +27,9 @@          ( Version(..), VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )-import Distribution.InstalledPackageInfo (installedPackageId)+import Distribution.InstalledPackageInfo (installedUnitId) import Distribution.Package-         ( InstalledPackageId(..), PackageIdentifier(..), PackageId,+         ( UnitId(..), PackageIdentifier(..), PackageId,            PackageName(..), Package(..), packageName          , packageVersion, Dependency(..) ) import Distribution.PackageDescription@@ -120,8 +120,37 @@ import qualified System.Win32 as Win32 #endif +--TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two+-- parts: one that has no policy and just does as it's told with all the+-- explicit options, and an optional initial part that applies certain+-- policies (like if we should add the Cabal lib as a dep, and if so which+-- version). This could be structured as an action that returns a fully+-- elaborated 'SetupScriptOptions' containing no remaining policy choices.+--+-- See also the discussion at https://github.com/haskell/cabal/pull/3094+ data SetupScriptOptions = SetupScriptOptions {+    -- | The version of the Cabal library to use (if 'useDependenciesExclusive'+    -- is not set). A suitable version of the Cabal library must be installed+    -- (or for some build-types be the one cabal-install was built with).+    --+    -- The version found also determines the version of the Cabal specification+    -- that we us for talking to the Setup.hs, unless overridden by+    -- 'useCabalSpecVersion'.+    --     useCabalVersion          :: VersionRange,++    -- | This is the version of the Cabal specification that we believe that+    -- this package uses. This affects the semantics and in particular the+    -- Setup command line interface.+    --+    -- This is similar to 'useCabalVersion' but instead of probing the system+    -- for a version of the /Cabal library/ you just say exactly which version+    -- of the /spec/ we will use. Using this also avoid adding the Cabal+    -- library as an additional dependency, so add it to 'useDependencies'+    -- if needed.+    --+    useCabalSpecVersion      :: Maybe Version,     useCompiler              :: Maybe Compiler,     usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,@@ -133,18 +162,29 @@     forceExternalSetupMethod :: Bool,      -- | List of dependencies to use when building Setup.hs-    useDependencies :: [(InstalledPackageId, PackageId)],+    useDependencies :: [(UnitId, PackageId)],      -- | Is the list of setup dependencies exclusive?     ---    -- This is here for legacy reasons. Before the introduction of the explicit-    -- setup stanza in .cabal files we compiled Setup.hs scripts with all-    -- packages in the environment visible, but we will needed to restrict-    -- _some_ packages; in particular, we need to restrict the version of Cabal-    -- that the setup script gets linked against (this was the only "dependency-    -- constraint" that we had previously for Setup scripts).+    -- When this is @False@, if we compile the Setup.hs script we do so with+    -- the list in 'useDependencies' but all other packages in the environment+    -- are also visible. Additionally, a suitable version of @Cabal@ library+    -- is added to the list of dependencies (see 'useCabalVersion').+    --+    -- When @True@, only the 'useDependencies' packages are used, with other+    -- packages in the environment hidden.+    --+    -- This feature is here to support the setup stanza in .cabal files that+    -- specifies explicit (and exclusive) dependencies, as well as the old+    -- style with no dependencies.     useDependenciesExclusive :: Bool, +    -- | Should we build the Setup.hs with CPP version macros available?+    -- We turn this on when we have a setup stanza in .cabal that declares+    -- explicit setup dependencies.+    --+    useVersionMacros         :: Bool,+     -- Used only by 'cabal clean' on Windows.     --     -- Note: win32 clean hack@@ -174,12 +214,14 @@ defaultSetupScriptOptions :: SetupScriptOptions defaultSetupScriptOptions = SetupScriptOptions {     useCabalVersion          = anyVersion,+    useCabalSpecVersion      = Nothing,     useCompiler              = Nothing,     usePlatform              = Nothing,     usePackageDB             = [GlobalPackageDB, UserPackageDB],     usePackageIndex          = Nothing,     useDependencies          = [],     useDependenciesExclusive = False,+    useVersionMacros         = False,     useProgramConfig         = emptyProgramConfiguration,     useDistPref              = defaultDistPref,     useLoggingHandle         = Nothing,@@ -235,7 +277,9 @@     -- between the self and internal setup methods, which are     -- consistent with each other.   | buildType' == Custom             = externalSetupMethod-  | not (cabalVersion `withinRange`+  | maybe False (cabalVersion /=)+        (useCabalSpecVersion options)+ || not (cabalVersion `withinRange`          useCabalVersion options)    = externalSetupMethod   | isJust (useLoggingHandle options)     -- Forcing is done to use an external process e.g. due to parallel@@ -304,7 +348,8 @@ externalSetupMethod :: SetupMethod externalSetupMethod verbosity options pkg bt mkargs = do   debug verbosity $ "Using external setup method with build-type " ++ show bt-  debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options)+  debug verbosity $ "Using explicit dependencies: "+    ++ show (useDependenciesExclusive options)   createDirectoryIfMissingVerbose verbosity True setupDir   (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion@@ -335,20 +380,26 @@       Nothing    -> getInstalledPackages verbosity                     comp (usePackageDB options') conf -  cabalLibVersionToUse :: IO (Version, (Maybe InstalledPackageId)+  cabalLibVersionToUse :: IO (Version, (Maybe UnitId)                              ,SetupScriptOptions)-  cabalLibVersionToUse = do-    savedVer <- savedVersion-    case savedVer of-      Just version | version `withinRange` useCabalVersion options-        -> do updateSetupScript version bt-              -- Does the previously compiled setup executable still exist and-              -- is it up-to date?-              useExisting <- canUseExistingSetup version-              if useExisting-                then return (version, Nothing, options)-                else installedVersion-      _ -> installedVersion+  cabalLibVersionToUse =+    case useCabalSpecVersion options of+      Just version -> do+        updateSetupScript version bt+        writeFile setupVersionFile (show version ++ "\n")+        return (version, Nothing, options)+      Nothing  -> do+        savedVer <- savedVersion+        case savedVer of+          Just version | version `withinRange` useCabalVersion options+            -> do updateSetupScript version bt+                  -- Does the previously compiled setup executable still exist+                  -- and is it up-to date?+                  useExisting <- canUseExistingSetup version+                  if useExisting+                    then return (version, Nothing, options)+                    else installedVersion+          _ -> installedVersion     where       -- This check duplicates the checks in 'getCachedSetupExecutable' /       -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice@@ -364,7 +415,7 @@           (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs                <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile -      installedVersion :: IO (Version, Maybe InstalledPackageId+      installedVersion :: IO (Version, Maybe UnitId                              ,SetupScriptOptions)       installedVersion = do         (comp,    conf,    options')  <- configureCompiler options@@ -411,10 +462,8 @@     UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"    installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration-                        -> IO (Version, Maybe InstalledPackageId+                        -> IO (Version, Maybe UnitId                               ,SetupScriptOptions)-  installedCabalVersion options' _ _ | packageName pkg == PackageName "Cabal" =-    return (packageVersion pkg, Nothing, options')   installedCabalVersion options' compiler conf = do     index <- maybeGetInstalledPackages options' compiler conf     let cabalDep   = Dependency (PackageName "Cabal") (useCabalVersion options')@@ -426,7 +475,7 @@                  ++ " but no suitable version is installed."       pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs               in return (packageVersion ipkginfo-                        ,Just . installedPackageId $ ipkginfo, options'')+                        ,Just . installedUnitId $ ipkginfo, options'')    bestVersion :: (a -> Version) -> [a] -> a   bestVersion f = firstMaximumBy (comparing (preference . f))@@ -499,7 +548,7 @@   -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.   getCachedSetupExecutable :: SetupScriptOptions-                           -> Version -> Maybe InstalledPackageId+                           -> Version -> Maybe UnitId                            -> IO FilePath   getCachedSetupExecutable options' cabalLibVersion                            maybeCabalLibInstalledPkgId = do@@ -534,7 +583,7 @@   -- Currently this is GHC/GHCJS only. It should really be generalised.   --   compileSetupExecutable :: SetupScriptOptions-                         -> Version -> Maybe InstalledPackageId -> Bool+                         -> Version -> Maybe UnitId -> Bool                          -> IO FilePath   compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId                          forceCompile = do@@ -552,14 +601,20 @@           cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])                               maybeCabalLibInstalledPkgId -          -- We do a few things differently once packages opt-in and declare-          -- a custom-settup stanza. In particular we then enforce the deps-          -- specified, but also let the Setup.hs use the version macros.-          newPedanticDeps     = useDependenciesExclusive options'-          selectedDeps-            | newPedanticDeps = useDependencies options'-            | otherwise       = useDependencies options' ++ cabalDep-          addRenaming (ipid, pid) = (ipid, pid, defaultRenaming)+          -- With 'useDependenciesExclusive' we enforce the deps specified,+          -- so only the given ones can be used. Otherwise we allow the use+          -- of packages in the ambient environment, and add on a dep on the+          -- Cabal library.+          --+          -- With 'useVersionMacros' we use a version CPP macros .h file.+          --+          -- Both of these options should be enabled for packages that have+          -- opted-in and declared a custom-settup stanza.+          --+          selectedDeps | useDependenciesExclusive options'+                                   = useDependencies options'+                       | otherwise = useDependencies options' ++ cabalDep+          addRenaming (ipid, _) = (ipid, defaultRenaming)           cppMacrosFile = setupDir </> "setup_macros.h"           ghcOptions = mempty {               ghcOptVerbosity       = Flag verbosity@@ -569,17 +624,19 @@             , ghcOptObjDir          = Flag setupDir             , ghcOptHiDir           = Flag setupDir             , ghcOptSourcePathClear = Flag True-            , ghcOptSourcePath      = toNubListR [workingDir]+            , ghcOptSourcePath      = case bt of+                                      Custom -> toNubListR [workingDir]+                                      _      -> mempty             , ghcOptPackageDBs      = usePackageDB options''-            , ghcOptHideAllPackages = Flag newPedanticDeps-            , ghcOptCabal           = Flag newPedanticDeps+            , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')+            , ghcOptCabal           = Flag (useDependenciesExclusive options')             , ghcOptPackages        = toNubListR $ map addRenaming selectedDeps             , ghcOptCppIncludes     = toNubListR [ cppMacrosFile-                                                 | newPedanticDeps ]+                                                 | useVersionMacros options' ]             , ghcOptExtra           = toNubListR extraOpts             }-      let ghcCmdLine = renderGhcOptions compiler ghcOptions-      when newPedanticDeps $+      let ghcCmdLine = renderGhcOptions compiler platform ghcOptions+      when (useVersionMacros options') $         rewriteFile cppMacrosFile (generatePackageVersionMacros                                      [ pid | (_ipid, pid) <- selectedDeps ])       case useLoggingHandle options of
cabal/cabal-install/Distribution/Client/SrcDist.hs view
@@ -33,7 +33,7 @@ import Distribution.Version   (Version(..), orLaterVersion)  import System.FilePath ((</>), (<.>))-import Control.Monad (when, unless)+import Control.Monad (when, unless, liftM) import System.Directory (doesFileExist, removeFile, canonicalizePath) import System.Process (runProcess, waitForProcess) import System.Exit    (ExitCode(..))@@ -41,9 +41,8 @@ -- |Create a source distribution. sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do-  pkg <- return . flattenPackageDescription-         =<< readPackageDescription verbosity-         =<< defaultPackageDesc verbosity+  pkg <- liftM flattenPackageDescription+    (readPackageDescription verbosity =<< defaultPackageDesc verbosity)   let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)                 else withTempDirectory verbosity tmpTargetDir "sdist."   -- 'withTempDir' fails if we don't create 'tmpTargetDir'...
cabal/cabal-install/Distribution/Client/Tar.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Tar@@ -15,94 +15,27 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Tar (-  -- * High level \"all in one\" operations+  -- * @tar.gz@ operations   createTarGzFile,   extractTarGzFile, -  -- * Converting between internal and external representation-  read,-  write,-  writeEntries,--  -- * Packing and unpacking files to\/from internal representation-  pack,-  unpack,--  -- * Tar entry and associated types-  Entry(..),-  entryPath,-  EntryContent(..),-  Ownership(..),-  FileSize,-  Permissions,-  EpochTime,-  DevMajor,-  DevMinor,-  TypeCode,-  Format(..),+  -- * Other local utils   buildTreeRefTypeCode,   buildTreeSnapshotTypeCode,   isBuildTreeRefTypeCode,-  entrySizeInBlocks,-  entrySizeInBytes,--  -- * Constructing simple entry values-  simpleEntry,-  fileEntry,-  directoryEntry,--  -- * TarPath type-  TarPath,-  toTarPath,-  fromTarPath,--  -- ** Sequences of tar entries-  Entries(..),-  foldrEntries,-  foldlEntries,-  unfoldrEntries,-  mapEntries,   filterEntries,-  entriesIndex,-+  filterEntriesM,+  entriesToList,   ) where -import Data.Char     (ord)-import Data.Int      (Int64)-import Data.Bits     (Bits, shiftL, testBit)-import Data.List     (foldl')-import Numeric       (readOct, showOct)-import Control.Applicative (Applicative(..))-import Control.Monad (MonadPlus(mplus), when, ap, liftM)-import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy    as BS+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Check as Tar+import qualified Codec.Compression.GZip  as GZip import qualified Distribution.Client.GZipUtils as GZipUtils -import System.FilePath-         ( (</>) )-import qualified System.FilePath         as FilePath.Native-import qualified System.FilePath.Windows as FilePath.Windows-import qualified System.FilePath.Posix   as FilePath.Posix-import System.Directory-         ( getDirectoryContents, doesDirectoryExist-         , getPermissions, createDirectoryIfMissing, copyFile )-import qualified System.Directory as Permissions-         ( Permissions(executable) )-import Distribution.Client.Compat.FilePerms-         ( setFileExecutable )-import System.Posix.Types-         ( FileMode )-import Distribution.Client.Compat.Time-         ( EpochTime, getModTime )-import System.IO-         ( IOMode(ReadMode), openBinaryFile, hFileSize )-import System.IO.Unsafe (unsafeInterleaveIO)--import Prelude hiding (read)-+import Control.Exception (Exception(..), throw)  -- -- * High level operations@@ -113,839 +46,65 @@                 -> FilePath  -- ^ Directory to archive, relative to base dir                 -> IO () createTarGzFile tar base dir =-  BS.writeFile tar . GZip.compress . write =<< pack base [dir]+  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]  extractTarGzFile :: FilePath -- ^ Destination directory                  -> FilePath -- ^ Expected subdir (to check for tarbombs)                  -> FilePath -- ^ Tarball                 -> IO () extractTarGzFile dir expected tar =-  unpack dir . checkTarbomb expected . read+  Tar.unpack dir . Tar.checkTarbomb expected . Tar.read   . GZipUtils.maybeDecompress =<< BS.readFile tar ------ * Entry type---+instance (Exception a, Exception b) => Exception (Either a b) where+  toException (Left  e) = toException e+  toException (Right e) = toException e -type FileSize  = Int64-type DevMajor  = Int-type DevMinor  = Int-type TypeCode  = Char-type Permissions = FileMode+  fromException e =+    case fromException e of+      Just e' -> Just (Left e')+      Nothing -> case fromException e of+                   Just e' -> Just (Right e')+                   Nothing -> Nothing --- | Tar archive entry.----data Entry = Entry { -    -- | The path of the file or directory within the archive. This is in a-    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.-    entryTarPath :: !TarPath,--    -- | The real content of the entry. For 'NormalFile' this includes the-    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.-    entryContent :: !EntryContent,--    -- | File permissions (Unix style file mode).-    entryPermissions :: !Permissions,--    -- | The user and group to which this file belongs.-    entryOwnership :: !Ownership,--    -- | The time the file was last modified.-    entryTime :: !EpochTime,--    -- | The tar format the archive is using.-    entryFormat :: !Format-  }- -- | Type code for the local build tree reference entry type. We don't use the -- symbolic link entry type because it allows only 100 ASCII characters for the -- path.-buildTreeRefTypeCode :: TypeCode+buildTreeRefTypeCode :: Tar.TypeCode buildTreeRefTypeCode = 'C'  -- | Type code for the local build tree snapshot entry type.-buildTreeSnapshotTypeCode :: TypeCode+buildTreeSnapshotTypeCode :: Tar.TypeCode buildTreeSnapshotTypeCode = 'S'  -- | Is this a type code for a build tree reference?-isBuildTreeRefTypeCode :: TypeCode -> Bool+isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool isBuildTreeRefTypeCode typeCode   | (typeCode == buildTreeRefTypeCode      || typeCode == buildTreeSnapshotTypeCode) = True   | otherwise                                  = False --- | Native 'FilePath' of the file or directory within the archive.----entryPath :: Entry -> FilePath-entryPath = fromTarPath . entryTarPath---- | Return the size of an entry in bytes.-entrySizeInBytes :: Entry -> FileSize-entrySizeInBytes = (*512) . fromIntegral . entrySizeInBlocks---- | Return the number of blocks in an entry.-entrySizeInBlocks :: Entry -> Int-entrySizeInBlocks entry = 1 + case entryContent entry of-  NormalFile     _   size -> bytesToBlocks size-  OtherEntryType _ _ size -> bytesToBlocks size-  _                       -> 0-  where-    bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)---- | The content of a tar archive entry, which depends on the type of entry.------ Portable archives should contain only 'NormalFile' and 'Directory'.----data EntryContent = NormalFile      ByteString !FileSize-                  | Directory-                  | SymbolicLink    !LinkTarget-                  | HardLink        !LinkTarget-                  | CharacterDevice !DevMajor !DevMinor-                  | BlockDevice     !DevMajor !DevMinor-                  | NamedPipe-                  | OtherEntryType  !TypeCode ByteString !FileSize--data Ownership = Ownership {-    -- | The owner user name. Should be set to @\"\"@ if unknown.-    ownerName :: String,--    -- | The owner group name. Should be set to @\"\"@ if unknown.-    groupName :: String,--    -- | Numeric owner user id. Should be set to @0@ if unknown.-    ownerId :: !Int,--    -- | Numeric owner group id. Should be set to @0@ if unknown.-    groupId :: !Int-  }---- | There have been a number of extensions to the tar file format over the--- years. They all share the basic entry fields and put more meta-data in--- different extended headers.----data Format =--     -- | This is the classic Unix V7 tar format. It does not support owner and-     -- group names, just numeric Ids. It also does not support device numbers.-     V7Format--     -- | The \"USTAR\" format is an extension of the classic V7 format. It was-     -- later standardised by POSIX. It has some restrictions but is the most-     -- portable format.-     ---   | UstarFormat--     -- | The GNU tar implementation also extends the classic V7 format, though-     -- in a slightly different way from the USTAR format. In general for new-     -- archives the standard USTAR/POSIX should be used.-     ---   | GnuFormat-  deriving Eq---- | @rw-r--r--@ for normal files-ordinaryFilePermissions :: Permissions-ordinaryFilePermissions   = 0o0644---- | @rwxr-xr-x@ for executable files-executableFilePermissions :: Permissions-executableFilePermissions = 0o0755---- | @rwxr-xr-x@ for directories-directoryPermissions :: Permissions-directoryPermissions  = 0o0755--isExecutable :: Permissions -> Bool-isExecutable p = testBit p 0 || testBit p 6 -- user or other executable---- | An 'Entry' with all default values except for the file name and type. It--- uses the portable USTAR/POSIX format (see 'UstarHeader').------ You can use this as a basis and override specific fields, eg:------ > (emptyEntry name HardLink) { linkTarget = target }----simpleEntry :: TarPath -> EntryContent -> Entry-simpleEntry tarpath content = Entry {-    entryTarPath     = tarpath,-    entryContent     = content,-    entryPermissions = case content of-                         Directory -> directoryPermissions-                         _         -> ordinaryFilePermissions,-    entryOwnership   = Ownership "" "" 0 0,-    entryTime        = 0,-    entryFormat      = UstarFormat-  }---- | A tar 'Entry' for a file.------ Entry  fields such as file permissions and ownership have default values.------ You can use this as a basis and override specific fields. For example if you--- need an executable file you could use:------ > (fileEntry name content) { fileMode = executableFileMode }----fileEntry :: TarPath -> ByteString -> Entry-fileEntry name fileContent =-  simpleEntry name (NormalFile fileContent (BS.length fileContent))---- | A tar 'Entry' for a directory.------ Entry fields such as file permissions and ownership have default values.----directoryEntry :: TarPath -> Entry-directoryEntry name = simpleEntry name Directory------- * Tar paths------- | The classic tar format allowed just 100 characters for the file name. The--- USTAR format extended this with an extra 155 characters, however it uses a--- complex method of splitting the name between the two sections.------ Instead of just putting any overflow into the extended area, it uses the--- extended area as a prefix. The aggravating insane bit however is that the--- prefix (if any) must only contain a directory prefix. That is the split--- between the two areas must be on a directory separator boundary. So there is--- no simple calculation to work out if a file name is too long. Instead we--- have to try to find a valid split that makes the name fit in the two areas.------ The rationale presumably was to make it a bit more compatible with old tar--- programs that only understand the classic format. A classic tar would be--- able to extract the file name and possibly some dir prefix, but not the--- full dir prefix. So the files would end up in the wrong place, but that's--- probably better than ending up with the wrong names too.------ So it's understandable but rather annoying.------ * Tar paths use POSIX format (ie @\'/\'@ directory separators), irrespective---   of the local path conventions.------ * The directory separator between the prefix and name is /not/ stored.----data TarPath = TarPath FilePath -- path name, 100 characters max.-                       FilePath -- path prefix, 155 characters max.-  deriving (Eq, Ord)---- | Convert a 'TarPath' to a native 'FilePath'.------ The native 'FilePath' will use the native directory separator but it is not--- otherwise checked for validity or sanity. In particular:------ * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is---   not valid on Windows.------ * The tar path may be an absolute path or may contain @\"..\"@ components.---   For security reasons this should not usually be allowed, but it is your---   responsibility to check for these conditions (eg using 'checkSecurity').----fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath name prefix) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix-                          ++ FilePath.Posix.splitDirectories name-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id---- | Convert a native 'FilePath' to a 'TarPath'.------ The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a--- description of the problem with splitting long 'FilePath's.----toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for-                  -- directories a 'TarPath' must always use a trailing @\/@.-          -> FilePath -> Either String TarPath-toTarPath isDir = splitLongPath-                . addTrailingSep-                . FilePath.Posix.joinPath-                . FilePath.Native.splitDirectories-  where-    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator-                   | otherwise = id---- | Take a sanitized path, split on directory separators and try to pack it--- into the 155 + 100 tar file name format.------ The strategy is this: take the name-directory components in reverse order--- and try to fit as many components into the 100 long name area as possible.--- If all the remaining components fit in the 155 name area then we win.----splitLongPath :: FilePath -> Either String TarPath-splitLongPath path =-  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of-    Left err                 -> Left err-    Right (name, [])         -> Right (TarPath name "")-    Right (name, first:rest) -> case packName prefixMax remainder of-      Left err               -> Left err-      Right (_     , _ : _)  -> Left "File name too long (cannot split)"-      Right (prefix, [])     -> Right (TarPath name prefix)-      where-        -- drop the '/' between the name and prefix:-        remainder = init first : rest--  where-    nameMax, prefixMax :: Int-    nameMax   = 100-    prefixMax = 155--    packName _      []     = Left "File name empty"-    packName maxLen (c:cs)-      | n > maxLen         = Left "File name too long"-      | otherwise          = Right (packName' maxLen n [c] cs)-      where n = length c--    packName' maxLen n ok (c:cs)-      | n' <= maxLen             = packName' maxLen n' (c:ok) cs-                                     where n' = n + length c-    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)---- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and--- 'HardLink' entry types.----newtype LinkTarget = LinkTarget FilePath-  deriving (Eq, Ord)---- | Convert a tar 'LinkTarget' to a native 'FilePath'.----fromLinkTarget :: LinkTarget -> FilePath-fromLinkTarget (LinkTarget path) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id------- * Entries type------- | A tar archive is a sequence of entries.-data Entries = Next Entry Entries-             | Done-             | Fail String--unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries-unfoldrEntries f = unfold-  where-    unfold x = case f x of-      Left err             -> Fail err-      Right Nothing        -> Done-      Right (Just (e, x')) -> Next e (unfold x')--foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a-foldrEntries next done fail' = fold-  where-    fold (Next e es) = next e (fold es)-    fold Done        = done-    fold (Fail err)  = fail' err--foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a-foldlEntries f = fold-  where-    fold a (Next e es) = (fold $! f a e) es-    fold a Done        = Right a-    fold _ (Fail err)  = Left err--mapEntries :: (Entry -> Entry) -> Entries -> Entries-mapEntries f = foldrEntries (Next . f) Done Fail--filterEntries :: (Entry -> Bool) -> Entries -> Entries+filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e filterEntries p =-  foldrEntries-    (\entry rest -> if p entry-                      then Next entry rest-                      else rest)-    Done Fail--checkEntries :: (Entry -> Maybe String) -> Entries -> Entries-checkEntries checkEntry =-  foldrEntries-    (\entry rest -> case checkEntry entry of-                      Nothing  -> Next entry rest-                      Just err -> Fail err)-    Done Fail--entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)-entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty------- * Checking------- | This function checks a sequence of tar entries for file name security--- problems. It checks that:------ * file paths are not absolute------ * file paths do not contain any path components that are \"@..@\"------ * file names are valid------ These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive--- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the--- link target. A failure in any entry terminates the sequence of entries with--- an error.----checkSecurity :: Entries -> Entries-checkSecurity = checkEntries checkEntrySecurity--checkTarbomb :: FilePath -> Entries -> Entries-checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)--checkEntrySecurity :: Entry -> Maybe String-checkEntrySecurity entry = case entryContent entry of-    HardLink     link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    SymbolicLink link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    _                 -> check (entryPath entry)--  where-    check name-      | not (FilePath.Native.isRelative name)-      = Just $ "Absolute file name in tar archive: " ++ show name--      | not (FilePath.Native.isValid name)-      = Just $ "Invalid file name in tar archive: " ++ show name--      | ".." `elem` FilePath.Native.splitDirectories name-      = Just $ "Invalid file name in tar archive: " ++ show name--      | otherwise = Nothing--checkEntryTarbomb :: FilePath -> Entry -> Maybe String-checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing-  where-    -- Ignore some special entries we will not unpack anyway-    nonFilesystemEntry =-      case entryContent entry of-        OtherEntryType 'g' _ _ -> True --PAX global header-        OtherEntryType 'x' _ _ -> True --PAX individual header-        _                      -> False--checkEntryTarbomb expectedTopDir entry =-  case FilePath.Native.splitDirectories (entryPath entry) of-    (topDir:_) | topDir == expectedTopDir -> Nothing-    s -> Just $ "File in tar archive is not in the expected directory. "-             ++ "Expected: " ++ show expectedTopDir-             ++ " but got the following hierarchy: "-             ++ show s-------- * Reading-----read :: ByteString -> Entries-read = unfoldrEntries getEntry--getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))-getEntry bs-  | BS.length header < 512 = Left "truncated tar archive"--  -- Tar files end with at least two blocks of all '0'. Checking this serves-  -- two purposes. It checks the format but also forces the tail of the data-  -- which is necessary to close the file if it came from a lazily read file.-  | BS.head bs == 0 = case BS.splitAt 1024 bs of-      (end, trailing)-        | BS.length end /= 1024        -> Left "short tar trailer"-        | not (BS.all (== 0) end)      -> Left "bad tar trailer"-        | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"-        | otherwise                    -> Right Nothing--  | otherwise  = partial $ do--  case (chksum_, format_) of-    (Ok chksum, _   ) | correctChecksum header chksum -> return ()-    (Ok _,      Ok _) -> fail "tar checksum error"-    _                 -> fail "data is not in tar format"--  -- These fields are partial, have to check them-  format   <- format_;   mode     <- mode_;-  uid      <- uid_;      gid      <- gid_;-  size     <- size_;     mtime    <- mtime_;-  devmajor <- devmajor_; devminor <- devminor_;--  let content = BS.take size (BS.drop 512 bs)-      padding = (512 - size) `mod` 512-      bs'     = BS.drop (512 + size + padding) bs--      entry = Entry {-        entryTarPath     = TarPath name prefix,-        entryContent     = case typecode of-                   '\0' -> NormalFile      content size-                   '0'  -> NormalFile      content size-                   '1'  -> HardLink        (LinkTarget linkname)-                   '2'  -> SymbolicLink    (LinkTarget linkname)-                   '3'  -> CharacterDevice devmajor devminor-                   '4'  -> BlockDevice     devmajor devminor-                   '5'  -> Directory-                   '6'  -> NamedPipe-                   '7'  -> NormalFile      content size-                   _    -> OtherEntryType  typecode content size,-        entryPermissions = mode,-        entryOwnership   = Ownership uname gname uid gid,-        entryTime        = mtime,-        entryFormat      = format-    }--  return (Just (entry, bs'))--  where-   header = BS.take 512 bs--   name       = getString   0 100 header-   mode_      = getOct    100   8 header-   uid_       = getOct    108   8 header-   gid_       = getOct    116   8 header-   size_      = getOct    124  12 header-   mtime_     = getOct    136  12 header-   chksum_    = getOct    148   8 header-   typecode   = getByte   156     header-   linkname   = getString 157 100 header-   magic      = getChars  257   8 header-   uname      = getString 265  32 header-   gname      = getString 297  32 header-   devmajor_  = getOct    329   8 header-   devminor_  = getOct    337   8 header-   prefix     = getString 345 155 header--- trailing   = getBytes  500  12 header--   format_ = case magic of-    "\0\0\0\0\0\0\0\0" -> return V7Format-    "ustar\NUL00"      -> return UstarFormat-    "ustar  \NUL"      -> return GnuFormat-    _                  -> fail "tar entry not in a recognised format"--correctChecksum :: ByteString -> Int -> Bool-correctChecksum header checksum = checksum == checksum'-  where-    -- sum of all 512 bytes in the header block,-    -- treating each byte as an 8-bit unsigned value-    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'-    -- treating the 8 bytes of chksum as blank characters.-    header'   = BS.concat [BS.take 148 header,-                           BS.Char8.replicate 8 ' ',-                           BS.drop 156 header]---- * TAR format primitive input--getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a-getOct off len header-  | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))-  | null octstr          = return 0-  | otherwise            = case readOct octstr of-               [(x,[])] -> return x-               _        -> fail "tar header is malformed (bad numeric encoding)"-  where-    bytes  = getBytes off len header-    octstr = BS.Char8.unpack-           . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')-           . BS.Char8.dropWhile (== ' ')-           $ bytes--    -- Some tar programs switch into a binary format when they try to represent-    -- field values that will not fit in the required width when using the text-    -- octal format. In particular, the UID/GID fields can only hold up to 2^21-    -- while in the binary format can hold up to 2^32. The binary format uses-    -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.-    parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =-      return $! shiftL (fromIntegral byte3) 24-              + shiftL (fromIntegral byte2) 16-              + shiftL (fromIntegral byte1) 8-              + shiftL (fromIntegral byte0) 0-    parseBinInt _ = fail "tar header uses non-standard number encoding"--getBytes :: Int64 -> Int64 -> ByteString -> ByteString-getBytes off len = BS.take len . BS.drop off--getByte :: Int64 -> ByteString -> Char-getByte off bs = BS.Char8.index bs off--getChars :: Int64 -> Int64 -> ByteString -> String-getChars off len = BS.Char8.unpack . getBytes off len--getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0')-                    . getBytes off len--data Partial a = Error String | Ok a-  deriving Functor--partial :: Partial a -> Either String a-partial (Error msg) = Left msg-partial (Ok x)      = Right x--instance Applicative Partial where-    pure          = return-    (<*>)         = ap--instance Monad Partial where-    return        = Ok-    Error m >>= _ = Error m-    Ok    x >>= k = k x-    fail          = Error------- * Writing------- | Create the external representation of a tar archive by serialising a list--- of tar entries.------ * The conversion is done lazily.----write :: [Entry] -> ByteString-write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]---- | Same as 'write', but for 'Entries'.-writeEntries :: Entries -> ByteString-writeEntries entries = BS.concat $ foldrEntries (\e res -> putEntry e : res)-                       [BS.replicate (512*2) 0] error entries--putEntry :: Entry -> ByteString-putEntry entry = case entryContent entry of-  NormalFile       content size -> BS.concat [ header, content, padding size ]-  OtherEntryType _ content size -> BS.concat [ header, content, padding size ]-  _                             -> header-  where-    header       = putHeader entry-    padding size = BS.replicate paddingSize 0-      where paddingSize = fromIntegral (negate size `mod` 512)--putHeader :: Entry -> ByteString-putHeader entry =-     BS.concat [ BS.take 148 block-               , BS.Char8.pack $ putOct 7 checksum-               , BS.Char8.singleton ' '-               , BS.drop 156 block ]-  where-    -- putHeaderNoChkSum returns a String, so we convert it to the final-    -- representation before calculating the checksum.-    block    = BS.Char8.pack . putHeaderNoChkSum $ entry-    checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block--putHeaderNoChkSum :: Entry -> String-putHeaderNoChkSum Entry {-    entryTarPath     = TarPath name prefix,-    entryContent     = content,-    entryPermissions = permissions,-    entryOwnership   = ownership,-    entryTime        = modTime,-    entryFormat      = format-  } =--  concat-    [ putString  100 $ name-    , putOct       8 $ permissions-    , putOct       8 $ ownerId ownership-    , putOct       8 $ groupId ownership-    , putOct      12 $ contentSize-    , putOct      12 $ modTime-    , fill         8 $ ' ' -- dummy checksum-    , putChar8       $ typeCode-    , putString  100 $ linkTarget-    ] ++-  case format of-  V7Format    ->-      fill 255 '\NUL'-  UstarFormat -> concat-    [ putString    8 $ "ustar\NUL00"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putOct       8 $ deviceMajor-    , putOct       8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  GnuFormat -> concat-    [ putString    8 $ "ustar  \NUL"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putGnuDev    8 $ deviceMajor-    , putGnuDev    8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  where-    (typeCode, contentSize, linkTarget,-     deviceMajor, deviceMinor) = case content of-       NormalFile      _ size            -> ('0' , size, [],   0,     0)-       Directory                         -> ('5' , 0,    [],   0,     0)-       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link, 0,     0)-       HardLink        (LinkTarget link) -> ('1' , 0,    link, 0,     0)-       CharacterDevice major minor       -> ('3' , 0,    [],   major, minor)-       BlockDevice     major minor       -> ('4' , 0,    [],   major, minor)-       NamedPipe                         -> ('6' , 0,    [],   0,     0)-       OtherEntryType  code _ size       -> (code, size, [],   0,     0)--    putGnuDev w n = case content of-      CharacterDevice _ _ -> putOct w n-      BlockDevice     _ _ -> putOct w n-      _                   -> replicate w '\NUL'---- * TAR format primitive output--type FieldWidth = Int--putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'----TODO: check integer widths, eg for large file sizes-putOct :: (Show a, Integral a) => FieldWidth -> a -> String-putOct n x =-  let octStr = take (n-1) $ showOct x ""-   in fill (n - length octStr - 1) '0'-   ++ octStr-   ++ putChar8 '\NUL'--putChar8 :: Char -> String-putChar8 c = [c]--fill :: FieldWidth -> Char -> String-fill n c = replicate n c------- * Unpacking-----unpack :: FilePath -> Entries -> IO ()-unpack baseDir entries = unpackEntries [] (checkSecurity entries)-                     >>= emulateLinks--  where-    -- We're relying here on 'checkSecurity' to make sure we're not scribbling-    -- files all over the place.--    unpackEntries _     (Fail err)      = fail err-    unpackEntries links Done            = return links-    unpackEntries links (Next entry es) = case entryContent entry of-      NormalFile file _ -> extractFile entry path file-                        >> unpackEntries links es-      Directory         -> extractDir path-                        >> unpackEntries links es-      HardLink     link -> (unpackEntries $! saveLink path link links) es-      SymbolicLink link -> (unpackEntries $! saveLink path link links) es-      _                 -> unpackEntries links es --ignore other file types-      where-        path = entryPath entry--    extractFile entry path content = do-      -- Note that tar archives do not make sure each directory is created-      -- before files they contain, indeed we may have to create several-      -- levels of directory.-      createDirectoryIfMissing True absDir-      BS.writeFile absPath content-      when (isExecutable (entryPermissions entry))-           (setFileExecutable absPath)-      where-        absDir  = baseDir </> FilePath.Native.takeDirectory path-        absPath = baseDir </> path--    extractDir path = createDirectoryIfMissing True (baseDir </> path)--    saveLink path link links = seq (length path)-                             $ seq (length link')-                             $ (path, link'):links-      where link' = fromLinkTarget link--    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->-      let absPath   = baseDir </> relPath-          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget-       in copyFile absTarget absPath------- * Packing-----pack :: FilePath   -- ^ Base directory-     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir-     -> IO [Entry]-pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir--preparePaths :: FilePath -> [FilePath] -> IO [FilePath]-preparePaths baseDir paths =-  fmap concat $ interleave-    [ do isDir  <- doesDirectoryExist (baseDir </> path)-         if isDir-           then do entries <- getDirectoryContentsRecursive (baseDir </> path)-                   return (FilePath.Native.addTrailingPathSeparator path-                         : map (path </>) entries)-           else return [path]-    | path <- paths ]--packPaths :: FilePath -> [FilePath] -> IO [Entry]-packPaths baseDir paths =-  interleave-    [ do tarpath <- either fail return (toTarPath isDir relpath)-         if isDir then packDirectoryEntry filepath tarpath-                  else packFileEntry      filepath tarpath-    | relpath <- paths-    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath-          filepath = baseDir </> relpath ]--interleave :: [IO a] -> IO [a]-interleave = unsafeInterleaveIO . go-  where-    go []     = return []-    go (x:xs) = do-      x'  <- x-      xs' <- interleave xs-      return (x':xs')--packFileEntry :: FilePath -- ^ Full path to find the file on the local disk-              -> TarPath  -- ^ Path to use for the tar Entry in the archive-              -> IO Entry-packFileEntry filepath tarpath = do-  mtime   <- getModTime filepath-  perms   <- getPermissions filepath-  file    <- openBinaryFile filepath ReadMode-  size    <- hFileSize file-  content <- BS.hGetContents file-  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {-    entryPermissions = if Permissions.executable perms-                         then executableFilePermissions-                         else ordinaryFilePermissions,-    entryTime = mtime-  }--packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk-                   -> TarPath  -- ^ Path to use for the tar Entry in the archive-                   -> IO Entry-packDirectoryEntry filepath tarpath = do-  mtime   <- getModTime filepath-  return (directoryEntry tarpath) {-    entryTime = mtime-  }--getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir0 =-  fmap tail (recurseDirectories dir0 [""])--recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]-recurseDirectories _    []         = return []-recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do-  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)+  Tar.foldEntries+    (\e es -> if p e then Tar.Next e es else es)+    Tar.Done+    Tar.Fail -  files' <- recurseDirectories base (dirs' ++ dirs)-  return (dir : files ++ files')+filterEntriesM :: Monad m => (Tar.Entry -> m Bool)+               -> Tar.Entries e -> m (Tar.Entries e)+filterEntriesM p =+  Tar.foldEntries+    (\entry rest -> do+         keep <- p entry+         xs   <- rest+         if keep+           then return (Tar.Next entry xs)+           else return xs)+    (return Tar.Done)+    (return . Tar.Fail) -  where-    collect files dirs' []              = return (reverse files, reverse dirs')-    collect files dirs' (entry:entries) | ignore entry-                                        = collect files dirs' entries-    collect files dirs' (entry:entries) = do-      let dirEntry  = dir </> entry-          dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry-      isDirectory <- doesDirectoryExist (base </> dirEntry)-      if isDirectory-        then collect files (dirEntry':dirs') entries-        else collect (dirEntry:files) dirs' entries+entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]+entriesToList = Tar.foldEntries (:) [] throw -    ignore ['.']      = True-    ignore ['.', '.'] = True-    ignore _          = False
cabal/cabal-install/Distribution/Client/Targets.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Targets@@ -42,7 +44,9 @@   UserConstraint(..),   userConstraintPackageName,   readUserConstraint,-  userToPackageConstraint+  userToPackageConstraint,+  dispFlagAssignment,+  parseFlagAssignment,    ) where @@ -51,7 +55,8 @@          , PackageIdentifier(..), packageName, packageVersion          , Dependency(Dependency) ) import Distribution.Client.Types-         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) )+         ( SourcePackage(..), PackageLocation(..), OptionalStanza(..)+         , ResolvedPkgLoc, UnresolvedSourcePackage ) import Distribution.Client.Dependency.Types          ( PackageConstraint(..), ConstraintSource(..)          , LabeledPackageConstraint(..) )@@ -59,10 +64,13 @@ import qualified Distribution.Client.World as World import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils-import Distribution.Client.HttpUtils ( HttpTransport(..) ) import Distribution.Client.Utils ( tryFindPackageDesc )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )  import Distribution.PackageDescription          ( GenericPackageDescription, FlagName(..), FlagAssignment )@@ -95,6 +103,8 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP          ( (+++), (<++) )+import qualified Distribution.Compat.Semigroup as Semi+         ( Semigroup((<>)) ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint          ( (<>), (<+>) )@@ -106,6 +116,8 @@          ( doesFileExist, doesDirectoryExist ) import Network.URI          ( URI(..), URIAuth(..), parseAbsoluteURI )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary)  -- ------------------------------------------------------------ -- * User targets@@ -182,8 +194,10 @@      -- | A fully specified source package.      --    | SpecificSourcePackage pkg-  deriving Show+  deriving (Eq, Show, Generic) +instance Binary pkg => Binary (PackageSpecifier pkg)+ pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _)       = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg@@ -357,17 +371,17 @@ -- resolveUserTargets :: Package pkg                    => Verbosity-                   -> HttpTransport+                   -> RepoContext                    -> FilePath                    -> PackageIndex pkg                    -> [UserTarget]-                   -> IO [PackageSpecifier SourcePackage]-resolveUserTargets verbosity transport worldFile available userTargets = do+                   -> IO [PackageSpecifier UnresolvedSourcePackage]+resolveUserTargets verbosity repoCtxt worldFile available userTargets = do      -- given the user targets, get a list of fully or partially resolved     -- package references     packageTargets <- mapM (readPackageTarget verbosity)-                  =<< mapM (fetchPackageTarget transport verbosity) . concat+                  =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat                   =<< mapM (expandUserTarget worldFile) userTargets      -- users are allowed to give package names case-insensitively, so we must@@ -453,15 +467,15 @@  -- | Fetch any remote targets so that they can be read. ---fetchPackageTarget :: HttpTransport-                   -> Verbosity+fetchPackageTarget :: Verbosity+                   -> RepoContext                    -> PackageTarget (PackageLocation ())-                   -> IO (PackageTarget (PackageLocation FilePath))-fetchPackageTarget transport verbosity target = case target of+                   -> IO (PackageTarget ResolvedPkgLoc)+fetchPackageTarget verbosity repoCtxt target = case target of     PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)     PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)     PackageTargetLocation location  -> do-      location' <- fetchPackage transport verbosity (fmap (const Nothing) location)+      location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location)       return (PackageTargetLocation location')  @@ -470,8 +484,8 @@ -- This only affects targets given by location, named targets are unaffected. -- readPackageTarget :: Verbosity-                  -> PackageTarget (PackageLocation FilePath)-                  -> IO (PackageTarget SourcePackage)+                  -> PackageTarget ResolvedPkgLoc+                  -> IO (PackageTarget UnresolvedSourcePackage) readPackageTarget verbosity target = case target of      PackageTargetNamed pkgname constraints userTarget ->@@ -524,7 +538,7 @@     extractTarballPackageCabalFile tarballFile tarballOriginalLoc =           either (die . formatErr) return         . check-        . Tar.entriesIndex+        . accumEntryMap         . Tar.filterEntries isCabalFile         . Tar.read         . GZipUtils.maybeDecompress@@ -532,7 +546,11 @@       where         formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg -        check (Left e)  = Left e+        accumEntryMap = Tar.foldlEntries+                          (\m e -> Map.insert (Tar.entryTarPath e) e m)+                          Map.empty++        check (Left e)  = Left (show e)         check (Right m) = case Map.elems m of             []     -> Left noCabalFile             [file] -> case Tar.entryContent file of@@ -662,7 +680,10 @@  instance Monoid PackageNameEnv where   mempty = PackageNameEnv (const [])-  mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =+  mappend = (Semi.<>)++instance Semi.Semigroup PackageNameEnv where+  PackageNameEnv lookupA <> PackageNameEnv lookupB =     PackageNameEnv (\name -> lookupA name ++ lookupB name)  indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv@@ -691,8 +712,10 @@    | UserConstraintSource    PackageName    | UserConstraintFlags     PackageName FlagAssignment    | UserConstraintStanzas   PackageName [OptionalStanza]-  deriving (Show,Eq)+  deriving (Eq, Show, Generic) +instance Binary UserConstraint+ userConstraintPackageName :: UserConstraint -> PackageName userConstraintPackageName uc = case uc of   UserConstraintVersion   name _ -> name@@ -728,7 +751,6 @@          "expected a package name followed by a constraint, which is "       ++ "either a version range, 'installed', 'source' or flags" ---FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where   disp (UserConstraintVersion   pkgname verrange) = disp pkgname                                                     <+> disp verrange@@ -738,12 +760,6 @@                                                     <+> Disp.text "source"   disp (UserConstraintFlags     pkgname flags)    = disp pkgname                                                     <+> dispFlagAssignment flags-    where-      dispFlagAssignment = Disp.hsep . map dispFlagValue-      dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f-      dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f-      dispFlagName (FlagName f) = Disp.text f-   disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname                                                     <+> dispStanzas stanzas     where@@ -753,37 +769,51 @@    parse = parse >>= parseConstraint     where-      spaces = Parse.satisfy isSpace >> Parse.skipSpaces-       parseConstraint pkgname =             ((parse >>= return . UserConstraintVersion pkgname)-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "installed"                 return (UserConstraintInstalled pkgname))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "source"                 return (UserConstraintSource pkgname))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "test"                 return (UserConstraintStanzas pkgname [TestStanzas]))-        +++ (do spaces+        +++ (do skipSpaces1                 _ <- Parse.string "bench"                 return (UserConstraintStanzas pkgname [BenchStanzas])))-        <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))+        <++ (do skipSpaces1+                flags <- parseFlagAssignment+                return (UserConstraintFlags pkgname flags)) -      parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)-      parseFlagValue =-            (do Parse.optional (Parse.char '+')-                f <- parseFlagName-                return (f, True))-        +++ (do _ <- Parse.char '-'-                f <- parseFlagName-                return (f, False))-      parseFlagName = liftM FlagName ident+--TODO: [code cleanup] move these somewhere else+dispFlagAssignment :: FlagAssignment -> Disp.Doc+dispFlagAssignment = Disp.hsep . map dispFlagValue+  where+    dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f+    dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f+    dispFlagName (FlagName f) = Disp.text f -      ident :: Parse.ReadP r String-      ident = Parse.munch1 identChar >>= \s -> check s >> return s-        where-          identChar c   = isAlphaNum c || c == '_' || c == '-'-          check ('-':_) = Parse.pfail-          check _       = return ()+parseFlagAssignment :: Parse.ReadP r FlagAssignment+parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1+  where+    parseFlagValue =+          (do Parse.optional (Parse.char '+')+              f <- parseFlagName+              return (f, True))+      +++ (do _ <- Parse.char '-'+              f <- parseFlagName+              return (f, False))+    parseFlagName = liftM (FlagName . lowercase) ident++    ident :: Parse.ReadP r String+    ident = Parse.munch1 identChar >>= \s -> check s >> return s+      where+        identChar c   = isAlphaNum c || c == '_' || c == '-'+        check ('-':_) = Parse.pfail+        check _       = return ()++skipSpaces1 :: Parse.ReadP r ()+skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces+
cabal/cabal-install/Distribution/Client/Types.hs view
@@ -1,4 +1,9 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Types@@ -16,9 +21,8 @@  import Distribution.Package          ( PackageName, PackageId, Package(..)-         , mkPackageKey, PackageKey, InstalledPackageId(..)-         , HasInstalledPackageId(..), PackageInstalled(..)-         , LibraryName, packageKeyLibraryName )+         , UnitId(..), mkUnitId, pkgName+         , HasUnitId(..), PackageInstalled(..) ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.PackageDescription@@ -33,31 +37,50 @@ import qualified Distribution.Client.ComponentDeps as CD import Distribution.Version          ( VersionRange )-import Distribution.Simple.Compiler-         ( Compiler, packageKeySupported ) import Distribution.Text (display)-import qualified Distribution.InstalledPackageInfo as Info  import Data.Map (Map)-import Network.URI (URI, nullURI)+import Network.URI (URI(..), URIAuth(..), nullURI) import Data.ByteString.Lazy (ByteString) import Control.Exception          ( SomeException )+import GHC.Generics (Generic)+import Distribution.Compat.Binary (Binary(..)) + newtype Username = Username { unUsername :: String } newtype Password = Password { unPassword :: String }  -- | This is the information we get from a @00-index.tar.gz@ hackage index. -- data SourcePackageDb = SourcePackageDb {-  packageIndex       :: PackageIndex SourcePackage,+  packageIndex       :: PackageIndex UnresolvedSourcePackage,   packagePreferences :: Map PackageName VersionRange }+  deriving (Eq, Generic) +instance Binary SourcePackageDb+ -- ------------------------------------------------------------ -- * Various kinds of information about packages -- ------------------------------------------------------------ +-- | Within Cabal the library we no longer have a @InstalledPackageId@ type.+-- That's because it deals with the compilers' notion of a registered library,+-- and those really are libraries not packages. Those are now named units.+--+-- The package management layer does however deal with installed packages, as+-- whole packages not just as libraries. So we do still need a type for+-- installed package ids. At the moment however we track instaled packages via+-- their primary library, which is a unit id. In future this may change+-- slightly and we may distinguish these two types and have an explicit+-- conversion when we register units with the compiler.+--+type InstalledPackageId = UnitId++installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId+installedPackageId = installedUnitId+ -- | Subclass of packages that have specific versioned dependencies. -- -- So for example a not-yet-configured package has dependencies on version@@ -66,44 +89,47 @@ --  dependency graphs) only make sense on this subclass of package types. -- class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> ComponentDeps [InstalledPackageId]+  depends :: pkg -> ComponentDeps [UnitId]  instance PackageFixedDeps InstalledPackageInfo where-  depends = CD.fromInstalled . installedDepends+  depends pkg = CD.fromInstalled (display (pkgName (packageId pkg)))+                                 (installedDepends pkg)   -- | In order to reuse the implementation of PackageIndex which relies on--- 'InstalledPackageId', we need to be able to synthesize these IDs prior+-- 'UnitId', we need to be able to synthesize these IDs prior -- to installation.  Eventually, we'll move to a representation of--- 'InstalledPackageId' which can be properly computed before compilation+-- 'UnitId' which can be properly computed before compilation -- (of course, it's a bit of a misnomer since the packages are not actually -- installed yet.)  In any case, we'll synthesize temporary installed package -- IDs to use as keys during install planning.  These should never be written -- out!  Additionally, they need to be guaranteed unique within the install -- plan.-fakeInstalledPackageId :: PackageId -> InstalledPackageId-fakeInstalledPackageId = InstalledPackageId . (".fake."++) . display+fakeUnitId :: PackageId -> UnitId+fakeUnitId = mkUnitId . (".fake."++) . display  -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the -- final configure process will be independent of the environment. ---data ConfiguredPackage = ConfiguredPackage-       SourcePackage       -- package info, including repo-       FlagAssignment      -- complete flag assignment for the package-       [OptionalStanza]    -- list of enabled optional stanzas for the package-       (ComponentDeps [ConfiguredId])-                           -- set of exact dependencies (installed or source).-                           -- These must be consistent with the 'buildDepends'-                           -- in the 'PackageDescription' that you'd get by-                           -- applying the flag assignment and optional stanzas.-  deriving Show+data ConfiguredPackage loc = ConfiguredPackage {+       confPkgSource :: SourcePackage loc, -- package info, including repo+       confPkgFlags :: FlagAssignment,     -- complete flag assignment for the package+       confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package+       confPkgDeps :: ComponentDeps [ConfiguredId]+                               -- set of exact dependencies (installed or source).+                               -- These must be consistent with the 'buildDepends'+                               -- in the 'PackageDescription' that you'd get by+                               -- applying the flag assignment and optional stanzas.+    }+  deriving (Eq, Show, Generic) +instance (Binary loc) => Binary (ConfiguredPackage loc)+ -- | A ConfiguredId is a package ID for a configured package. ----- Once we configure a source package we know it's InstalledPackageId--- (at least, in principle, even if we have to fake it currently). It is still+-- Once we configure a source package we know it's UnitId. It is still -- however useful in lots of places to also know the source ID for the package. -- We therefore bundle the two. --@@ -111,81 +137,69 @@ -- configuration parameters and dependencies have been specified). -- -- TODO: I wonder if it would make sense to promote this datatype to Cabal--- and use it consistently instead of InstalledPackageIds?+-- and use it consistently instead of UnitIds? data ConfiguredId = ConfiguredId {     confSrcId  :: PackageId-  , confInstId :: InstalledPackageId+  , confInstId :: UnitId   }+  deriving (Eq, Generic) +instance Binary ConfiguredId+ instance Show ConfiguredId where   show = show . confSrcId -instance Package ConfiguredPackage where-  packageId (ConfiguredPackage pkg _ _ _) = packageId pkg--instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ _ deps) = fmap (map confInstId) deps--instance HasInstalledPackageId ConfiguredPackage where-  installedPackageId = fakeInstalledPackageId . packageId---- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be--- installed already, hence itself ready to be installed.-data GenericReadyPackage srcpkg ipkg-   = ReadyPackage-       srcpkg                  -- see 'ConfiguredPackage'.-       (ComponentDeps [ipkg])  -- Installed dependencies.-  deriving (Eq, Show)--type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo+instance Package ConfiguredId where+  packageId = confSrcId -instance Package srcpkg => Package (GenericReadyPackage srcpkg ipkg) where-  packageId (ReadyPackage srcpkg _deps) = packageId srcpkg+instance HasUnitId ConfiguredId where+  installedUnitId = confInstId -instance (Package srcpkg, HasInstalledPackageId ipkg) =>-         PackageFixedDeps (GenericReadyPackage srcpkg ipkg) where-  depends (ReadyPackage _ deps) = fmap (map installedPackageId) deps+instance Package (ConfiguredPackage loc) where+  packageId cpkg = packageId (confPkgSource cpkg) -instance HasInstalledPackageId srcpkg =>-         HasInstalledPackageId (GenericReadyPackage srcpkg ipkg) where-  installedPackageId (ReadyPackage pkg _) = installedPackageId pkg+instance PackageFixedDeps (ConfiguredPackage loc) where+  depends cpkg = fmap (map installedUnitId) (confPkgDeps cpkg) +instance HasUnitId (ConfiguredPackage loc) where+  installedUnitId cpkg = fakeUnitId (packageId cpkg) --- | Extracts a package key from ReadyPackage, a common operation needed--- to calculate build paths.-readyPackageKey :: Compiler -> ReadyPackage -> PackageKey-readyPackageKey comp (ReadyPackage pkg deps) =-    mkPackageKey (packageKeySupported comp) (packageId pkg)-                 (map Info.libraryName (CD.nonSetupDeps deps))+-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be+-- installed already, hence itself ready to be installed.+newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.+  deriving (Eq, Show, Generic, Package, PackageFixedDeps, HasUnitId, Binary) --- | Extracts a library name from ReadyPackage, a common operation needed--- to calculate build paths.-readyLibraryName :: Compiler -> ReadyPackage -> LibraryName-readyLibraryName comp ready@(ReadyPackage pkg _) =-    packageKeyLibraryName (packageId pkg) (readyPackageKey comp ready)+type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)   -- | A package description along with the location of the package sources. ---data SourcePackage = SourcePackage {+data SourcePackage loc = SourcePackage {     packageInfoId        :: PackageId,     packageDescription   :: GenericPackageDescription,-    packageSource        :: PackageLocation (Maybe FilePath),+    packageSource        :: loc,     packageDescrOverride :: PackageDescriptionOverride   }-  deriving Show+  deriving (Eq, Show, Generic) +instance (Binary loc) => Binary (SourcePackage loc)++-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.+type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc+ -- | We sometimes need to override the .cabal file in the tarball with -- the newer one from the package index. type PackageDescriptionOverride = Maybe ByteString -instance Package SourcePackage where packageId = packageInfoId+instance Package (SourcePackage a) where packageId = packageInfoId  data OptionalStanza     = TestStanzas     | BenchStanzas-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Enum, Bounded, Show, Generic) +instance Binary OptionalStanza+ enableStanzas     :: [OptionalStanza]     -> GenericPackageDescription@@ -204,6 +218,10 @@ -- * Package locations and repositories -- ------------------------------------------------------------ +type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)++type ResolvedPkgLoc = PackageLocation FilePath+ data PackageLocation local =      -- | An unpacked package in the given dir, or current dir@@ -224,17 +242,40 @@ --TODO: --  * add support for darcs and other SCM style remote repos with a local cache --  | ScmPackage-  deriving (Show, Functor)+  deriving (Show, Functor, Eq, Ord, Generic) -data LocalRepo = LocalRepo-  deriving (Show,Eq)+instance Binary local => Binary (PackageLocation local) +-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier+-- versions do not, so we use manual Binary instances here+instance Binary URI where+  put (URI a b c d e) = do put a; put b; put c; put d; put e+  get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get+           return (URI a b c d e)++instance Binary URIAuth where+  put (URIAuth a b c) = do put a; put b; put c+  get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)+ data RemoteRepo =     RemoteRepo {       remoteRepoName     :: String,       remoteRepoURI      :: URI,-      remoteRepoRootKeys :: (), +      -- | Enable secure access?+      --+      -- 'Nothing' here represents "whatever the default is"; this is important+      -- to allow for a smooth transition from opt-in to opt-out security+      -- (once we switch to opt-out, all access to the central Hackage+      -- repository should be secure by default)+      remoteRepoSecure :: Maybe Bool,++      -- | Root key IDs (for bootstrapping)+      remoteRepoRootKeys :: [String],++      -- | Threshold for verification during bootstrapping+      remoteRepoKeyThreshold :: Int,+       -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a       -- special case we may know a repo supports both and want to try HTTPS       -- if we can, but still allow falling back to HTTP.@@ -244,20 +285,51 @@       remoteRepoShouldTryHttps :: Bool     } -  -- FIXME: discuss this type some more.+  deriving (Show, Eq, Ord, Generic) -  deriving (Show,Eq,Ord)+instance Binary RemoteRepo  -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: String -> RemoteRepo-emptyRemoteRepo name = RemoteRepo name nullURI () False+emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False -data Repo = Repo {-    repoKind     :: Either RemoteRepo LocalRepo,-    repoLocalDir :: FilePath-  }-  deriving (Show,Eq)+-- | Different kinds of repositories+--+-- NOTE: It is important that this type remains serializable.+data Repo =+    -- | Local repositories+    RepoLocal {+        repoLocalDir :: FilePath+      } +    -- | Standard (unsecured) remote repositores+  | RepoRemote {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }++    -- | Secure repositories+    --+    -- Although this contains the same fields as 'RepoRemote', we use a separate+    -- constructor to avoid confusing the two.+    --+    -- Not all access to a secure repo goes through the hackage-security+    -- library currently; code paths that do not still make use of the+    -- 'repoRemote' and 'repoLocalDir' fields directly.+  | RepoSecure {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }+  deriving (Show, Eq, Ord, Generic)++instance Binary Repo++-- | Check if this is a remote repo+maybeRepoRemote :: Repo -> Maybe RemoteRepo+maybeRepoRemote (RepoLocal    _localDir) = Nothing+maybeRepoRemote (RepoRemote r _localDir) = Just r+maybeRepoRemote (RepoSecure r _localDir) = Just r+ -- ------------------------------------------------------------ -- * Build results -- ------------------------------------------------------------@@ -271,8 +343,22 @@                   | BuildFailed     SomeException                   | TestsFailed     SomeException                   | InstallFailed   SomeException+  deriving (Show, Generic) data BuildSuccess = BuildOk         DocsResult TestsResult                                     (Maybe InstalledPackageInfo)+  deriving (Show, Generic)  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+  deriving (Show, Generic) data TestsResult = TestsNotTried | TestsOk+  deriving (Show, Generic)++instance Binary BuildFailure+instance Binary BuildSuccess+instance Binary DocsResult+instance Binary TestsResult++--FIXME: this is a total cheat+instance Binary SomeException where+  put _ = return ()+  get = fail "cannot serialise exceptions"
cabal/cabal-install/Distribution/Client/Update.hs view
@@ -10,39 +10,46 @@ -- -- -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-} module Distribution.Client.Update     ( update     ) where  import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..) )+         ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils-         ( DownloadResult(..), HttpTransport(..) )+         ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import Distribution.Client.IndexUtils-         ( updateRepoIndexCache )+         ( updateRepoIndexCache, Index(..) ) import Distribution.Client.JobControl          ( newParallelJobControl, spawnJob, collectJob )+import Distribution.Client.Setup+         ( RepoContext(..) )+import Distribution.Verbosity+         ( Verbosity )  import Distribution.Simple.Utils          ( writeFileAtomic, warn, notice )-import Distribution.Verbosity-         ( Verbosity )  import qualified Data.ByteString.Lazy       as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath (dropExtension)-import Data.Either (lefts)+import Data.Maybe (catMaybes)+import Data.Time (getCurrentTime) +import qualified Hackage.Security.Client as Sec+ -- | 'update' downloads the package list from all known servers-update :: HttpTransport -> Verbosity -> [Repo] -> IO ()-update _ verbosity [] =+update :: Verbosity -> RepoContext -> IO ()+update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."-update transport verbosity repos = do+update verbosity repoCtxt = do   jobCtrl <- newParallelJobControl-  let remoteRepos = lefts (map repoKind repos)+  let repos       = repoContextRepos repoCtxt+      remoteRepos = catMaybes (map maybeRepoRemote repos)   case remoteRepos of     [] -> return ()     [remoteRepo] ->@@ -51,17 +58,31 @@     _ -> notice verbosity . unlines             $ "Downloading the latest package lists from: "             : map (("- " ++) . remoteRepoName) remoteRepos-  mapM_ (spawnJob jobCtrl . updateRepo transport verbosity) repos+  mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos   mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: HttpTransport -> Verbosity -> Repo -> IO ()-updateRepo transport verbosity repo = case repoKind repo of-  Right LocalRepo -> return ()-  Left remoteRepo -> do-    downloadResult <- downloadIndex transport verbosity remoteRepo (repoLocalDir repo)-    case downloadResult of-      FileAlreadyInCache -> return ()-      FileDownloaded indexPath -> do-        writeFileAtomic (dropExtension indexPath) . maybeDecompress-                                                =<< BS.readFile indexPath-        updateRepoIndexCache verbosity repo+updateRepo :: Verbosity -> RepoContext -> Repo -> IO ()+updateRepo verbosity repoCtxt repo = do+  transport <- repoContextGetTransport repoCtxt+  case repo of+    RepoLocal{..} -> return ()+    RepoRemote{..} -> do+      downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir+      case downloadResult of+        FileAlreadyInCache -> return ()+        FileDownloaded indexPath -> do+          writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                  =<< BS.readFile indexPath+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+      ce <- if repoContextIgnoreExpiry repoCtxt+              then Just `fmap` getCurrentTime+              else return Nothing+      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce+      -- Update cabal's internal index as well so that it's not out of sync+      -- (If all access to the cache goes through hackage-security this can go)+      case updated of+        Sec.NoUpdates  ->+          return ()+        Sec.HasUpdates ->+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
cabal/cabal-install/Distribution/Client/Upload.hs view
@@ -1,11 +1,11 @@--- This is a quick hack for uploading packages to Hackage.--- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload--module Distribution.Client.Upload (check, upload, report) where+module Distribution.Client.Upload (check, upload, uploadDoc, report) where -import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))+import Distribution.Client.Types ( Username(..), Password(..)+                                 , RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils-         ( isOldHackageURI, HttpTransport(..), remoteRepoTryUpgradeToHttps )+         ( HttpTransport(..), remoteRepoTryUpgradeToHttps )+import Distribution.Client.Setup+         ( RepoContext(..) )  import Distribution.Simple.Utils (notice, warn, info, die) import Distribution.Verbosity (Verbosity)@@ -16,45 +16,88 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport  import Network.URI (URI(uriPath), parseURI)+import Network.HTTP (Header(..), HeaderName(..))  import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho)+import System.Exit      (exitFailure) import Control.Exception (bracket)-import System.FilePath  ((</>), takeExtension)+import System.FilePath  ((</>), takeExtension, takeFileName) import qualified System.FilePath.Posix as FilePath.Posix ((</>)) import System.Directory import Control.Monad (forM_, when)+import Data.Maybe (catMaybes)  type Auth = Maybe (String, String) ---FIXME: how do we find this path for an arbitrary hackage server?--- is it always at some fixed location relative to the server root?-legacyUploadURI :: URI-Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"- checkURI :: URI-Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"+Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/"+                           ++ "hackage-scripts/check-pkg" -upload :: HttpTransport -> Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()-upload transport verbosity repos mUsername mPassword paths = do+upload :: Verbosity -> RepoContext+       -> Maybe Username -> Maybe Password -> [FilePath]+       -> IO ()+upload verbosity repoCtxt mUsername mPassword paths = do+    let repos = repoContextRepos repoCtxt+    transport  <- repoContextGetTransport repoCtxt     targetRepo <--      case [ remoteRepo | Left remoteRepo <- map repoKind repos ] of-        [] -> die $ "Cannot upload. No remote repositories are configured."+      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of+        [] -> die "Cannot upload. No remote repositories are configured."         rs -> remoteRepoTryUpgradeToHttps transport (last rs)     let targetRepoURI = remoteRepoURI targetRepo-        uploadURI-          | isOldHackageURI targetRepoURI-          = legacyUploadURI-          | otherwise-          = targetRepoURI {-              uriPath = uriPath targetRepoURI FilePath.Posix.</> "upload"-            }+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> "upload"+        }     Username username <- maybe promptUsername return mUsername     Password password <- maybe promptPassword return mPassword     let auth = Just (username,password)-    flip mapM_ paths $ \path -> do+    forM_ paths $ \path -> do       notice verbosity $ "Uploading " ++ path ++ "... "       handlePackage transport verbosity uploadURI auth path +uploadDoc :: Verbosity -> RepoContext+          -> Maybe Username -> Maybe Password -> FilePath+          -> IO ()+uploadDoc verbosity repoCtxt mUsername mPassword path = do+    let repos = repoContextRepos repoCtxt+    transport  <- repoContextGetTransport repoCtxt+    targetRepo <-+      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of+        [] -> die $ "Cannot upload. No remote repositories are configured."+        rs -> remoteRepoTryUpgradeToHttps transport (last rs)+    let targetRepoURI = remoteRepoURI targetRepo+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> "package/" ++ pkgid ++ "/docs"+        }+        (reverseSuffix, reversePkgid) = break (== '-')+                                        (reverse (takeFileName path))+        pkgid = reverse $ tail reversePkgid+    when (reverse reverseSuffix /= "docs.tar.gz"+          || null reversePkgid || head reversePkgid /= '-') $+      die "Expected a file name matching the pattern <pkgid>-docs.tar.gz"+    Username username <- maybe promptUsername return mUsername+    Password password <- maybe promptPassword return mPassword++    let auth = Just (username,password)+        headers =+          [ Header HdrContentType "application/x-tar"+          , Header HdrContentEncoding "gzip"+          ]+    notice verbosity $ "Uploading documentation " ++ path ++ "... "+    resp <- putHttpFile transport verbosity uploadURI path auth headers+    case resp of+      (200,_)     ->+        notice verbosity "Ok"+      (code,err)  -> do+        notice verbosity $ "Error uploading documentation "+                        ++ path ++ ": "+                        ++ "http code " ++ show code ++ "\n"+                        ++ err+        exitFailure+ promptUsername :: IO Username promptUsername = do   putStr "Hackage username: "@@ -72,43 +115,49 @@   putStrLn ""   return passwd -report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()-report verbosity repos mUsername mPassword = do-      Username username <- maybe promptUsername return mUsername-      Password password <- maybe promptPassword return mPassword-      let auth = (username,password)-      forM_ repos $ \repo -> case repoKind repo of-        Left remoteRepo-            -> do dotCabal <- defaultCabalDir-                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo-                  -- We don't want to bomb out just because we haven't built any packages from this repo yet-                  srcExists <- doesDirectoryExist srcDir-                  when srcExists $ do-                    contents <- getDirectoryContents srcDir-                    forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->-                        do inp <- readFile (srcDir </> logFile)-                           let (reportStr, buildLog) = read inp :: (String,String)-                           case BuildReport.parse reportStr of-                             Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME-                             Right report' ->-                                 do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')-                                    BuildReport.uploadReports verbosity auth (remoteRepoURI remoteRepo) [(report', Just buildLog)]-                                    return ()-        Right{} -> return ()+report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()+report verbosity repoCtxt mUsername mPassword = do+  Username username <- maybe promptUsername return mUsername+  Password password <- maybe promptPassword return mPassword+  let auth        = (username, password)+      repos       = repoContextRepos repoCtxt+      remoteRepos = catMaybes (map maybeRepoRemote repos)+  forM_ remoteRepos $ \remoteRepo ->+      do dotCabal <- defaultCabalDir+         let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+         -- We don't want to bomb out just because we haven't built any packages+         -- from this repo yet.+         srcExists <- doesDirectoryExist srcDir+         when srcExists $ do+           contents <- getDirectoryContents srcDir+           forM_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->+             do inp <- readFile (srcDir </> logFile)+                let (reportStr, buildLog) = read inp :: (String,String)+                case BuildReport.parse reportStr of+                  Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME+                  Right report' ->+                    do info verbosity $ "Uploading report for "+                         ++ display (BuildReport.package report')+                       BuildReport.uploadReports verbosity repoCtxt auth+                         (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                       return () -check :: HttpTransport -> Verbosity -> [FilePath] -> IO ()-check transport verbosity paths = do-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Checking " ++ path ++ "... "-            handlePackage transport verbosity checkURI Nothing path+check :: Verbosity -> RepoContext -> [FilePath] -> IO ()+check verbosity repoCtxt paths = do+    transport <- repoContextGetTransport repoCtxt+    forM_ paths $ \path -> do+      notice verbosity $ "Checking " ++ path ++ "... "+      handlePackage transport verbosity checkURI Nothing path  handlePackage :: HttpTransport -> Verbosity -> URI -> Auth               -> FilePath -> IO () handlePackage transport verbosity uri auth path =   do resp <- postHttpFile transport verbosity uri path auth      case resp of-       (200,_)     -> do notice verbosity "Ok"-       (code,err)  -> do notice verbosity $ "Error uploading " ++ path ++ ": "-                                     ++ "http code " ++ show code ++ "\n"-                                     ++ err-+       (200,_)     ->+          notice verbosity "Ok"+       (code,err)  -> do+          notice verbosity $ "Error uploading " ++ path ++ ": "+                          ++ "http code " ++ show code ++ "\n"+                          ++ err+          exitFailure
cabal/cabal-install/Distribution/Client/Utils.hs view
@@ -3,10 +3,13 @@ module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy                                  , readMaybe-                                 , inDir, determineNumJobs, numberOfProcessors+                                 , inDir, logDirChange+                                 , determineNumJobs, numberOfProcessors                                  , removeExistingFile                                  , withTempFileName-                                 , makeAbsoluteToCwd, filePathToByteString+                                 , makeAbsoluteToCwd+                                 , makeRelativeToCwd, makeRelativeToDir+                                 , filePathToByteString                                  , byteStringToFilePath, tryCanonicalizePath                                  , canonicalizePathNoThrow                                  , moreRecentFile, existsAndIsMoreRecentThan@@ -20,6 +23,9 @@ import Distribution.Simple.Setup       ( Flag(..) ) import Distribution.Simple.Utils       ( die, findPackageDesc ) import qualified Data.ByteString.Lazy as BS+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Control.Monad          ( when ) import Data.Bits@@ -41,7 +47,7 @@          ( canonicalizePath, doesFileExist, getCurrentDirectory          , removeFile, setCurrentDirectory ) import System.FilePath-         ( (</>), isAbsolute )+         ( (</>), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO          ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0)@@ -57,7 +63,7 @@          ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) #endif -#if defined(mingw32_HOST_OS)+#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import Prelude hiding (ioError) import Control.Monad (liftM2, unless) import System.Directory (doesDirectoryExist)@@ -123,6 +129,9 @@     (\(name, h) -> hClose h >> action name)  -- | Executes the action in the specified directory.+--+-- Warning: This operation is NOT thread-safe, because current+-- working directory is a process-global concept. inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do@@ -130,6 +139,14 @@   setCurrentDirectory d   m `Exception.finally` setCurrentDirectory old +-- | Log directory change in 'make' compatible syntax+logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a+logDirChange _ Nothing m = m+logDirChange l (Just d) m = do+  l $ "cabal: Entering directory '" ++ d ++ "'\n"+  m `Exception.finally`+    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")+ foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt  -- The number of processors is not going to change during the duration of the@@ -152,6 +169,30 @@                        | otherwise       = do cwd <- getCurrentDirectory                                               return $! cwd </> path +-- | Given a path (relative or absolute), make it relative to the current+-- directory, including using @../..@ if necessary.+makeRelativeToCwd :: FilePath -> IO FilePath+makeRelativeToCwd path =+    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory++-- | Given a path (relative or absolute), make it relative to the given+-- directory, including using @../..@ if necessary.+makeRelativeToDir :: FilePath -> FilePath -> IO FilePath+makeRelativeToDir path dir =+    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir++-- | Given a canonical absolute path and canonical absolute dir, make the path+-- relative to the directory, including using @../..@ if necessary. Returns+-- the original absolute path if it is not on the same drive as the given dir.+makeRelativeCanonical :: FilePath -> FilePath -> FilePath+makeRelativeCanonical path dir+  | takeDrive path /= takeDrive dir = path+  | otherwise                       = go (splitPath path) (splitPath dir)+  where+    go (p:ps) (d:ds) | p == d = go ps ds+    go    []     []           = "./"+    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)+ -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is -- encoded as a little-endian 'Word32'. filePathToByteString :: FilePath -> BS.ByteString@@ -187,13 +228,12 @@         b2 = fromIntegral $ BS.index bs (i + 2)         b3 = fromIntegral $ BS.index bs (i + 3) --- | Workaround for the inconsistent behaviour of 'canonicalizePath'. It throws--- an error if the path refers to a non-existent file on *nix, but not on--- Windows.+-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always+-- throws an error if the path refers to a non-existent file. tryCanonicalizePath :: FilePath -> IO FilePath tryCanonicalizePath path = do   ret <- canonicalizePath path-#if defined(mingw32_HOST_OS)+#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)   exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)   unless exists $     ioError $ mkIOError doesNotExistErrorType "canonicalizePath"
cabal/cabal-install/Main.hs view
@@ -16,7 +16,7 @@ module Main (main) where  import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand, globalRepos+         ( GlobalFlags(..), globalCommand, withRepoContext          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand          , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)@@ -25,6 +25,7 @@          , installCommand, upgradeCommand, uninstallCommand          , FetchFlags(..), fetchCommand          , FreezeFlags(..), freezeCommand+         , genBoundsCommand          , GetFlags(..), getCommand, unpackCommand          , checkCommand          , formatCommand@@ -42,6 +43,7 @@          , ExecFlags(..), execCommand          , UserConfigFlags(..), userConfigCommand          , reportCommand+         , manpageCommand          ) import Distribution.Simple.Setup          ( HaddockFlags(..), haddockCommand, defaultHaddockFlags@@ -59,23 +61,28 @@          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config          ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff-         , userConfigUpdate )+         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) import Distribution.Client.Targets          ( readUserTargets ) import qualified Distribution.Client.List as List          ( list, info ) +--TODO: temporary import, just to force these modules to be built.+-- It will be replaced by import of new build command once merged.+import Distribution.Client.ProjectPlanning ()+import Distribution.Client.ProjectBuilding ()+ import Distribution.Client.Install            (install) import Distribution.Client.Configure          (configure) import Distribution.Client.Update             (update) import Distribution.Client.Exec               (exec) import Distribution.Client.Fetch              (fetch) import Distribution.Client.Freeze             (freeze)+import Distribution.Client.GenBounds          (genBounds) import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean)-import Distribution.Client.Upload as Upload   (upload, check, report)+import qualified Distribution.Client.Upload as Upload import Distribution.Client.Run                (run, splitRunArgs)-import Distribution.Client.HttpUtils          (configureTransport) import Distribution.Client.SrcDist            (sdist) import Distribution.Client.Get                (get) import Distribution.Client.Sandbox            (sandboxInit@@ -100,14 +107,17 @@                                               ,updateInstallDirs                                                ,configCompilerAux'+                                              ,getPersistOrConfigCompiler                                               ,configPackageDB') import Distribution.Client.Sandbox.PackageEnvironment                                               (setPackageDB                                               ,userPackageEnvironmentFile) import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)+import Distribution.Client.Tar                (createTarGzFile) import Distribution.Client.Types              (Password (..)) import Distribution.Client.Init               (initCabal)+import Distribution.Client.Manpage            (manpage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Client.Utils              (determineNumJobs #if defined(mingw32_HOST_OS)@@ -115,9 +125,9 @@ #endif                                               ,existsAndIsMoreRecentThan) +import Distribution.Package (packageId) import Distribution.PackageDescription-         ( BuildType(..), Executable(..), benchmarkName, benchmarkBuildInfo-         , testName, testBuildInfo, buildable )+         ( BuildType(..), Executable(..), buildable ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.PackageDescription.PrettyPrint@@ -127,8 +137,9 @@ import Distribution.Simple.Build          ( startInterpreter ) import Distribution.Simple.Command-         ( CommandParse(..), CommandUI(..), Command-         , commandsRun, commandAddAction, hiddenCommand )+         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)+         , CommandType(..), commandsRun, commandAddAction, hiddenCommand+         , commandFromSpec) import Distribution.Simple.Compiler          ( Compiler(..) ) import Distribution.Simple.Configure@@ -155,7 +166,8 @@  import System.Environment       (getArgs, getProgName) import System.Exit              (exitFailure)-import System.FilePath          (splitExtension, takeExtension)+import System.FilePath          ( dropExtension, splitExtension+                                , takeExtension, (</>), (<.>)) import System.IO                ( BufferMode(LineBuffering), hSetBuffering #ifdef mingw32_HOST_OS                                 , stderr@@ -163,7 +175,7 @@                                 , stdout ) import System.Directory         (doesFileExist, getCurrentDirectory) import Data.List                (intercalate)-import Data.Maybe               (mapMaybe)+import Data.Maybe               (listToMaybe) #if !MIN_VERSION_base(4,8,0) import Data.Monoid              (Monoid(..)) import Control.Applicative      (pure, (<$>))@@ -224,59 +236,71 @@     printNumericVersion = putStrLn $ display Paths_cabal_install.version     printVersion        = putStrLn $ "cabal-install version "                                   ++ display Paths_cabal_install.version-                                  ++ "\nusing version "+                                  ++ "\ncompiled using version "                                   ++ display cabalVersion                                   ++ " of the Cabal library " -    commands =-      [installCommand         `commandAddAction` installAction-      ,updateCommand          `commandAddAction` updateAction-      ,listCommand            `commandAddAction` listAction-      ,infoCommand            `commandAddAction` infoAction-      ,fetchCommand           `commandAddAction` fetchAction-      ,freezeCommand          `commandAddAction` freezeAction-      ,getCommand             `commandAddAction` getAction-      ,hiddenCommand $-       unpackCommand          `commandAddAction` unpackAction-      ,checkCommand           `commandAddAction` checkAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,uploadCommand          `commandAddAction` uploadAction-      ,reportCommand          `commandAddAction` reportAction-      ,runCommand             `commandAddAction` runAction-      ,initCommand            `commandAddAction` initAction-      ,configureExCommand     `commandAddAction` configureAction-      ,buildCommand           `commandAddAction` buildAction-      ,replCommand            `commandAddAction` replAction-      ,sandboxCommand         `commandAddAction` sandboxAction-      ,haddockCommand         `commandAddAction` haddockAction-      ,execCommand            `commandAddAction` execAction-      ,userConfigCommand      `commandAddAction` userConfigAction-      ,cleanCommand           `commandAddAction` cleanAction-      ,wrapperAction copyCommand-                     copyVerbosity     copyDistPref-      ,wrapperAction hscolourCommand-                     hscolourVerbosity hscolourDistPref-      ,wrapperAction registerCommand-                     regVerbosity      regDistPref-      ,testCommand            `commandAddAction` testAction-      ,benchmarkCommand       `commandAddAction` benchmarkAction-      ,hiddenCommand $-       uninstallCommand       `commandAddAction` uninstallAction-      ,hiddenCommand $-       formatCommand          `commandAddAction` formatAction-      ,hiddenCommand $-       upgradeCommand         `commandAddAction` upgradeAction-      ,hiddenCommand $-       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction-      ,hiddenCommand $-       actAsSetupCommand`commandAddAction` actAsSetupAction+    commands = map commandFromSpec commandSpecs+    commandSpecs =+      [ regularCmd installCommand installAction+      , regularCmd updateCommand updateAction+      , regularCmd listCommand listAction+      , regularCmd infoCommand infoAction+      , regularCmd fetchCommand fetchAction+      , regularCmd freezeCommand freezeAction+      , regularCmd getCommand getAction+      , hiddenCmd  unpackCommand unpackAction+      , regularCmd checkCommand checkAction+      , regularCmd sdistCommand sdistAction+      , regularCmd uploadCommand uploadAction+      , regularCmd reportCommand reportAction+      , regularCmd runCommand runAction+      , regularCmd initCommand initAction+      , regularCmd configureExCommand configureAction+      , regularCmd buildCommand buildAction+      , regularCmd replCommand replAction+      , regularCmd sandboxCommand sandboxAction+      , regularCmd haddockCommand haddockAction+      , regularCmd execCommand execAction+      , regularCmd userConfigCommand userConfigAction+      , regularCmd cleanCommand cleanAction+      , regularCmd genBoundsCommand genBoundsAction+      , wrapperCmd copyCommand copyVerbosity copyDistPref+      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref+      , wrapperCmd registerCommand regVerbosity regDistPref+      , regularCmd testCommand testAction+      , regularCmd benchmarkCommand benchmarkAction+      , hiddenCmd  uninstallCommand uninstallAction+      , hiddenCmd  formatCommand formatAction+      , hiddenCmd  upgradeCommand upgradeAction+      , hiddenCmd  win32SelfUpgradeCommand win32SelfUpgradeAction+      , hiddenCmd  actAsSetupCommand actAsSetupAction+      , hiddenCmd  manpageCommand (manpageAction commandSpecs)       ] +type Action = GlobalFlags -> IO ()++regularCmd :: CommandUI flags -> (flags -> [String] -> action)+           -> CommandSpec action+regularCmd ui action =+  CommandSpec ui ((flip commandAddAction) action) NormalCommand++hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)+          -> CommandSpec action+hiddenCmd ui action =+  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))+  HiddenCommand++wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)+           -> (flags -> Flag String) -> CommandSpec Action+wrapperCmd ui verbosity distPref =+  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand+ wrapperAction :: Monoid flags               => CommandUI flags               -> (flags -> Flag Verbosity)               -> (flags -> Flag String)-              -> Command (GlobalFlags -> IO ())+              -> Command Action wrapperAction command verbosityFlag distPrefFlag =   commandAddAction command     { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do@@ -288,7 +312,7 @@                  command (const flags) extraArgs  configureAction :: (ConfigFlags, ConfigExFlags)-                -> [String] -> GlobalFlags -> IO ()+                -> [String] -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) @@ -319,12 +343,13 @@       (compilerId comp) platform    maybeWithSandboxDirOnSearchPath useSandbox $+   withRepoContext verbosity globalFlags' $ \repoContext ->     configure verbosity               (configPackageDB' configFlags'')-              (globalRepos globalFlags')+              repoContext               comp platform conf configFlags'' configExFlags' extraArgs -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)       noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck@@ -378,7 +403,7 @@     numJobsCmdLineFlag = buildNumJobs buildFlags  -replAction :: (ReplFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action replAction (replFlags, buildExFlags) extraArgs globalFlags = do   cwd     <- getCurrentDirectory   pkgDesc <- findPackageDesc cwd@@ -418,12 +443,13 @@     onNoPkgDesc = do       (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags       let configFlags = savedConfigureFlags config-      (comp, _platform, programDb) <- configCompilerAux' configFlags+      (comp, platform, programDb) <- configCompilerAux' configFlags       programDb' <- reconfigurePrograms verbosity                                         (replProgramPaths replFlags)                                         (replProgramArgs replFlags)                                         programDb-      startInterpreter verbosity programDb' comp (configPackageDB' configFlags)+      startInterpreter verbosity programDb' comp platform+                       (configPackageDB' configFlags)  -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted:@@ -508,6 +534,9 @@                                       ++ "to be corrupt."             _ -> show err       case err of+        -- Note: the build config could have been generated by a custom setup+        -- script built against a different Cabal version, so it's crucial that+        -- we ignore the bad version error here.         ConfigStateFileBadVersion _ _ _ -> info verbosity msg         _                               -> do           let distVerbFlags = mempty@@ -656,7 +685,7 @@         ++ configureManually  installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> GlobalFlags -> IO ()+              -> [String] -> Action installAction (configFlags, _, installFlags, _) _ globalFlags   | fromFlagOrDefault False (installOnly installFlags) = do       let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)@@ -701,7 +730,8 @@                         haddockFlags { haddockDistPref = toFlag distPref }       globalFlags'    = savedGlobalFlags      config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags'-  -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future.+  -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the+  -- future.   conf' <- configureAllKnownPrograms verbosity conf    -- If we're working inside a sandbox and the user has set the -w option, we@@ -709,7 +739,8 @@   -- timestamp record for this compiler to the timestamp file.   configFlags'' <- case useSandbox of     NoSandbox               -> configAbsolutePaths $ configFlags'-    (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform configFlags'+    (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform+                                                     configFlags'    whenUsingSandbox useSandbox $ \sandboxDir -> do     initPackageDBIfNeeded verbosity configFlags'' comp conf'@@ -718,7 +749,7 @@     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile       (compilerId comp) platform -  -- FIXME: Passing 'SandboxPackageInfo' to install unconditionally here means+  -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means   -- that 'cabal install some-package' inside a sandbox will sometimes reinstall   -- modified add-source deps, even if they are not among the dependencies of   -- 'some-package'. This can also prevent packages that depend on older@@ -726,9 +757,10 @@   maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'                               comp platform conf useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $+    withRepoContext verbosity globalFlags' $ \repoContext ->       install verbosity               (configPackageDB' configFlags'')-              (globalRepos globalFlags')+              repoContext               comp platform conf'               useSandbox mSandboxPkgInfo               globalFlags' configFlags'' configExFlags'@@ -764,33 +796,47 @@   let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       testFlags'     = testFlags { testDistPref = toFlag distPref } -  -- the package was just configured, so the LBI must be available-  lbi <- getPersistBuildConfig distPref-  let pkgDescr = LBI.localPkgDescr lbi-      nameTestsOnly =-        LBI.foldComponent-          (const Nothing)-          (const Nothing)-          (\t ->-            if buildable (testBuildInfo t)-              then Just (testName t)-            else Nothing)-          (const Nothing)-      tests = mapMaybe nameTestsOnly $ LBI.pkgComponents pkgDescr-      extraArgs'-        | null extraArgs = tests-        | otherwise = extraArgs+  -- The package was just configured, so the LBI must be available.+  names <- componentNamesFromLBI distPref "test suites"+             (\c -> case c of { LBI.CTest{} -> True; _ -> False })+  let extraArgs'+        | null extraArgs = case names of+          ComponentNamesUnknown -> []+          ComponentNames names' -> [ name | LBI.CTestName name <- names' ]+        | otherwise      = extraArgs -  if null tests-    then notice verbosity "Package has no buildable test suites."-    else do-      maybeWithSandboxDirOnSearchPath useSandbox $-        build verbosity config distPref buildFlags' extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags' extraArgs' -      maybeWithSandboxDirOnSearchPath useSandbox $-        setupWrapper verbosity setupOptions Nothing-          Cabal.testCommand (const testFlags') extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    setupWrapper verbosity setupOptions Nothing+    Cabal.testCommand (const testFlags') extraArgs' +data ComponentNames = ComponentNamesUnknown+                    | ComponentNames [LBI.ComponentName]++-- | Return the names of all buildable components matching a given predicate.+componentNamesFromLBI :: FilePath -> String -> (LBI.Component -> Bool)+                         -> IO ComponentNames+componentNamesFromLBI distPref targetsDescr compPred = do+  eLBI <- tryGetPersistBuildConfig distPref+  case eLBI of+    Left err -> case err of+      -- Note: the build config could have been generated by a custom setup+      -- script built against a different Cabal version, so it's crucial that+      -- we ignore the bad version error here.+      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown+      _                               -> die (show err)+    Right lbi -> do+      let pkgDescr = LBI.localPkgDescr lbi+          names    = map LBI.componentName+                     . filter (buildable . LBI.componentBuildInfo)+                     . filter compPred $+                     LBI.pkgComponents pkgDescr+      if null names+        then die $ "Package has no buildable " ++ targetsDescr ++ "."+        else return $! (ComponentNames names)+ benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)                    -> [String] -> GlobalFlags                    -> IO ()@@ -816,34 +862,23 @@   let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }       benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } -  -- the package was just configured, so the LBI must be available-  lbi <- getPersistBuildConfig distPref-  let pkgDescr = LBI.localPkgDescr lbi-      nameBenchsOnly =-        LBI.foldComponent-          (const Nothing)-          (const Nothing)-          (const Nothing)-          (\b ->-            if buildable (benchmarkBuildInfo b)-              then Just (benchmarkName b)-            else Nothing)-      benchs = mapMaybe nameBenchsOnly $ LBI.pkgComponents pkgDescr-      extraArgs'-        | null extraArgs = benchs-        | otherwise = extraArgs+  -- The package was just configured, so the LBI must be available.+  names <- componentNamesFromLBI distPref "benchmarks"+           (\c -> case c of { LBI.CBench{} -> True; _ -> False; })+  let extraArgs'+        | null extraArgs = case names of+          ComponentNamesUnknown -> []+          ComponentNames names' -> [name | LBI.CBenchName name <- names']+        | otherwise      = extraArgs -  if null benchs-    then notice verbosity "Package has no buildable benchmarks."-    else do-      maybeWithSandboxDirOnSearchPath useSandbox $-        build verbosity config distPref buildFlags' extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags' extraArgs' -      maybeWithSandboxDirOnSearchPath useSandbox $-        setupWrapper verbosity setupOptions Nothing-          Cabal.benchmarkCommand (const benchmarkFlags') extraArgs'+  maybeWithSandboxDirOnSearchPath useSandbox $+    setupWrapper verbosity setupOptions Nothing+    Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' -haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()+haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do   let verbosity = fromFlag (haddockVerbosity haddockFlags)   (_useSandbox, config, distPref) <-@@ -856,8 +891,15 @@       setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }   setupWrapper verbosity setupScriptOptions Nothing     haddockCommand (const haddockFlags') extraArgs+  when (fromFlagOrDefault False $ haddockForHackage haddockFlags) $ do+    pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+    let dest = distPref </> name <.> "tar.gz"+        name = display (packageId pkg) ++ "-docs"+        docDir = distPref </> "doc" </> "html"+    createTarGzFile dest docDir name+    notice verbosity $ "Documentation tarball created: " ++ dest -cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()+cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do   (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags   distPref <- findSavedDistPref config (cleanDistPref cleanFlags)@@ -871,7 +913,7 @@   where     verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) -listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)   (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity@@ -883,15 +925,16 @@         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags-  List.list verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.list verbosity        (configPackageDB' configFlags)-       (globalRepos globalFlags')+       repoContext        comp        conf        listFlags        extraArgs -infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()+infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs@@ -904,16 +947,17 @@         }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAuxEx configFlags-  List.info verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    List.info verbosity        (configPackageDB' configFlags)-       (globalRepos globalFlags')+       repoContext        comp        conf        globalFlags'        infoFlags        targets -updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+updateAction :: Flag Verbosity -> [String] -> Action updateAction verbosityFlag extraArgs globalFlags = do   unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs@@ -921,11 +965,11 @@   (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity                            (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags'))-  update transport verbosity (globalRepos globalFlags')+  withRepoContext verbosity globalFlags' $ \repoContext ->+    update verbosity repoContext  upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)-              -> [String] -> GlobalFlags -> IO ()+              -> [String] -> Action upgradeAction _ _ _ = die $     "Use the 'cabal install' command instead of 'cabal upgrade'.\n"  ++ "You can install the latest version of a package using 'cabal install'. "@@ -939,7 +983,7 @@  ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "  ++ "packages (e.g. by using appropriate --constraint= flags)." -fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()+fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do   let verbosity = fromFlag (fetchVerbosity fetchFlags)   targets <- readUserTargets verbosity extraArgs@@ -947,13 +991,14 @@   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags-  fetch verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    fetch verbosity         (configPackageDB' configFlags)-        (globalRepos globalFlags')+        repoContext         comp platform conf globalFlags' fetchFlags         targets -freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do   let verbosity = fromFlag (freezeVerbosity freezeFlags)   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags@@ -964,20 +1009,44 @@   maybeWithSandboxPackageInfo verbosity configFlags globalFlags'                               comp platform conf useSandbox $ \mSandboxPkgInfo ->                               maybeWithSandboxDirOnSearchPath useSandbox $+    withRepoContext verbosity globalFlags' $ \repoContext ->       freeze verbosity             (configPackageDB' configFlags)-            (globalRepos globalFlags')+            repoContext             comp platform conf             mSandboxPkgInfo             globalFlags' freezeFlags -uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()+genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+genBoundsAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, conf) <- configCompilerAux' configFlags++  maybeWithSandboxPackageInfo verbosity configFlags globalFlags'+                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              maybeWithSandboxDirOnSearchPath useSandbox $+    withRepoContext verbosity globalFlags' $ \repoContext ->+      genBounds verbosity+            (configPackageDB' configFlags)+            repoContext+            comp platform conf+            mSandboxPkgInfo+            globalFlags' freezeFlags++uploadAction :: UploadFlags -> [String] -> Action uploadAction uploadFlags extraArgs globalFlags = do-  let verbosity = fromFlag (uploadVerbosity uploadFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags)   let uploadFlags' = savedUploadFlags config `mappend` uploadFlags       globalFlags' = savedGlobalFlags config `mappend` globalFlags       tarfiles     = extraArgs+  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $+    die "the 'upload' command expects at least one .tar.gz archive."+  when (fromFlag (uploadCheck uploadFlags')+        && fromFlag (uploadDoc uploadFlags')) $+    die "--check and --doc cannot be used together."   checkTarFiles extraArgs   maybe_password <-     case uploadPasswordCmd uploadFlags'@@ -985,21 +1054,32 @@                         getProgramInvocationOutput verbosity                         (simpleProgramInvocation xs xss)        _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'-  transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags'))-  if fromFlag (uploadCheck uploadFlags')-    then Upload.check transport verbosity tarfiles-    else upload transport-                verbosity-                (globalRepos globalFlags')-                (flagToMaybe $ uploadUsername uploadFlags')-                maybe_password-                tarfiles-  where+  withRepoContext verbosity globalFlags' $ \repoContext -> do+    if fromFlag (uploadCheck uploadFlags')+    then do+      Upload.check verbosity repoContext tarfiles+    else if fromFlag (uploadDoc uploadFlags')+    then do+      when (length tarfiles > 1) $+       die $ "the 'upload' command can only upload documentation "+             ++ "for one package at a time."+      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles+      Upload.uploadDoc verbosity+                       repoContext+                       (flagToMaybe $ uploadUsername uploadFlags')+                       maybe_password+                       tarfile+    else do+      Upload.upload verbosity+                    repoContext+                    (flagToMaybe $ uploadUsername uploadFlags')+                    maybe_password+                    tarfiles+    where+    verbosity = fromFlag (uploadVerbosity uploadFlags)     checkTarFiles tarfiles-      | null tarfiles-      = die "the 'upload' command expects one or more .tar.gz packages."       | not (null otherFiles)-      = die $ "the 'upload' command expects only .tar.gz packages: "+      = die $ "the 'upload' command expects only .tar.gz archives: "            ++ intercalate ", " otherFiles       | otherwise = sequence_                       [ do exists <- doesFileExist tarfile@@ -1010,15 +1090,23 @@             isTarGzFile file = case splitExtension file of               (file', ".gz") -> takeExtension file' == ".tar"               _              -> False+    generateDocTarball config = do+      notice verbosity+        "No documentation tarball specified. Building documentation tarball..."+      haddockAction (defaultHaddockFlags { haddockForHackage = Flag True })+                    [] globalFlags+      distPref <- findSavedDistPref config NoFlag+      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)+      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz" -checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+checkAction :: Flag Verbosity -> [String] -> Action checkAction verbosityFlag extraArgs _globalFlags = do   unless (null extraArgs) $     die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure -formatAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+formatAction :: Flag Verbosity -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do   let verbosity = fromFlag verbosityFlag   path <- case extraArgs of@@ -1029,18 +1117,19 @@   -- Uses 'writeFileAtomic' under the hood.   writeGenericPackageDescription path pkgDesc -uninstallAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+uninstallAction :: Flag Verbosity -> [String] -> Action uninstallAction _verbosityFlag extraArgs _globalFlags = do   let package = case extraArgs of         p:_ -> p         _   -> "PACKAGE_NAME"-  die $ "This version of 'cabal-install' does not support the 'uninstall' operation. "-        ++ "It will likely be implemented at some point in the future; in the meantime "-        ++ "you're advised to use either 'ghc-pkg unregister " ++ package ++ "' or "-        ++ "'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."+  die $ "This version of 'cabal-install' does not support the 'uninstall' "+    ++ "operation. "+    ++ "It will likely be implemented at some point in the future; "+    ++ "in the meantime you're advised to use either 'ghc-pkg unregister "+    ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'."  -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()+sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do   unless (null extraArgs) $     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs@@ -1050,7 +1139,7 @@   let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref }   sdist sdistFlags' sdistExFlags -reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()+reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do   unless (null extraArgs) $     die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs@@ -1060,11 +1149,12 @@   let globalFlags' = savedGlobalFlags config `mappend` globalFlags       reportFlags' = savedReportFlags config `mappend` reportFlags -  Upload.report verbosity (globalRepos globalFlags')+  withRepoContext verbosity globalFlags' $ \repoContext ->+   Upload.report verbosity repoContext     (flagToMaybe $ reportUsername reportFlags')     (flagToMaybe $ reportPassword reportFlags') -runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action runAction (buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)   let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck@@ -1086,39 +1176,43 @@   maybeWithSandboxDirOnSearchPath useSandbox $     run verbosity lbi exe exeArgs -getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do   let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs   (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity                            (globalFlags { globalRequireSandbox = Flag False })   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  get verbosity-    (globalRepos (savedGlobalFlags config))+  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->+   get verbosity+    repoContext     globalFlags'     getFlags     targets -unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+unpackAction :: GetFlags -> [String] -> Action unpackAction getFlags extraArgs globalFlags = do   getAction getFlags extraArgs globalFlags -initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()-initAction initFlags _extraArgs globalFlags = do+initAction :: InitFlags -> [String] -> Action+initAction initFlags extraArgs globalFlags = do+  when (extraArgs /= []) $+    die $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag (initVerbosity initFlags)   (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity                            (globalFlags { globalRequireSandbox = Flag False })   let configFlags  = savedConfigureFlags config   let globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags-  initCabal verbosity+  withRepoContext verbosity globalFlags' $ \repoContext ->+    initCabal verbosity             (configPackageDB' configFlags)-            (globalRepos globalFlags')+            repoContext             comp             conf             initFlags -sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()+sandboxAction :: SandboxFlags -> [String] -> Action sandboxAction sandboxFlags extraArgs globalFlags = do   let verbosity = fromFlag (sandboxVerbosity sandboxFlags)   case extraArgs of@@ -1153,29 +1247,35 @@   where     noExtraArgs = (<1) . length -execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()+execAction :: ExecFlags -> [String] -> Action execAction execFlags extraArgs globalFlags = do   let verbosity = fromFlag (execVerbosity execFlags)   (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags   let configFlags = savedConfigureFlags config-  (comp, platform, conf) <- configCompilerAux' configFlags+  (comp, platform, conf) <- getPersistOrConfigCompiler configFlags   exec verbosity useSandbox comp platform conf extraArgs -userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO ()+userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do   let verbosity = fromFlag (userConfigVerbosity ucflags)+      force     = fromFlag (userConfigForce ucflags)   case extraArgs of+    ("init":_) -> do+      path       <- configFile+      fileExists <- doesFileExist path+      if (not fileExists || (fileExists && force))+      then createDefaultConfigFile verbosity path+      else die $ path ++ " already exists."     ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags     ("update":_) -> userConfigUpdate verbosity globalFlags     -- Error handling.     [] -> die $ "Please specify a subcommand (see 'help user-config')"     _  -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs-+  where configFile = getConfigFilePath (globalConfigFile globalFlags)  -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. ---win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags-                          -> IO ()+win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do   let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path@@ -1184,7 +1284,7 @@ -- | Used as an entry point when cabal-install needs to invoke itself -- as a setup script. This can happen e.g. when doing parallel builds. ---actAsSetupAction :: ActAsSetupFlags -> [String] -> GlobalFlags -> IO ()+actAsSetupAction :: ActAsSetupFlags -> [String] -> Action actAsSetupAction actAsSetupFlags args _globalFlags =   let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)   in case bt of@@ -1194,3 +1294,13 @@     Make      -> Make.defaultMainArgs args     Custom               -> error "actAsSetupAction Custom"     (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType"++manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action+manpageAction commands _ extraArgs _ = do+  unless (null extraArgs) $+    die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs+  pname <- getProgName+  let cabalCmd = if takeExtension pname == ".exe"+                 then dropExtension pname+                 else pname+  putStrLn $ manpage cabalCmd commands
cabal/cabal-install/Setup.hs view
@@ -1,2 +1,63 @@-import Distribution.Simple-main = defaultMain+import Distribution.PackageDescription ( PackageDescription )+import Distribution.Simple ( defaultMainWithHooks+                           , simpleUserHooks+                           , postBuild+                           , postCopy+                           , postInst+                           )+import Distribution.Simple.InstallDirs ( mandir+                                       , CopyDest (NoCopyDest)+                                       )+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..)+                                          , absoluteInstallDirs+                                          )+import Distribution.Simple.Utils ( copyFiles+                                 , notice )+import Distribution.Simple.Setup ( buildVerbosity+                                 , copyDest+                                 , copyVerbosity+                                 , fromFlag+                                 , installVerbosity+                                 )+import Distribution.Verbosity ( Verbosity )++import System.IO ( openFile+                 , IOMode (WriteMode)+                 )+import System.Process ( runProcess )+import System.FilePath ( (</>) )++-- WARNING to editors of this file:+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- At this moment (Cabal 1.23), whatever you write here must be+-- compatible with ALL Cabal libraries which we support bootstrapping+-- with.  This is because pre-setup-depends versions of cabal-install will+-- build Setup.hs against the version of Cabal which MATCHES the library+-- that cabal-install was built against.  There is no way of overriding+-- this behavior without bumping the required 'cabal-version' in our+-- Cabal file.  Travis will let you know if we fail to install from+-- tarball!++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks+  { postBuild = \ _ flags _ lbi ->+      buildManpage lbi (fromFlag $ buildVerbosity flags)+  , postCopy = \ _ flags pkg lbi ->+      installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags)+  , postInst = \ _ flags pkg lbi ->+      installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest+  }++buildManpage :: LocalBuildInfo -> Verbosity -> IO ()+buildManpage lbi verbosity = do+  let cabal = buildDir lbi </> "cabal/cabal"+      manpage = buildDir lbi </> "cabal/cabal.1"+  manpageHandle <- openFile manpage WriteMode+  notice verbosity ("Generating manual page " ++ manpage ++ " ...")+  _ <- runProcess cabal ["manpage"] Nothing Nothing Nothing (Just manpageHandle) Nothing+  return ()++installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()+installManpage pkg lbi verbosity copy = do+  let destDir = mandir (absoluteInstallDirs pkg lbi copy) </> "man1"+  copyFiles verbosity destDir [(buildDir lbi </> "cabal", "cabal.1")]
cabal/cabal-install/bash-completion/cabal view
@@ -53,8 +53,27 @@     done } +__cabal_has_doubledash ()+{+    local c=1+    # Ignore the last word, because it is replaced anyways.+    # This allows expansion for flags on "cabal foo --",+    # but does not try to complete after "cabal foo -- ".+    local n=$((${#COMP_WORDS[@]} - 1))+    while [ $c -lt $n ]; do+        if [ "--" = "${COMP_WORDS[c]}" ]; then+            return 0+        fi+        ((c++))+    done+    return 1+}+ _cabal() {+    # no completion past cabal arguments.+    __cabal_has_doubledash && return+     # get the word currently being completed     local cur     cur=${COMP_WORDS[$COMP_CWORD]}
cabal/cabal-install/bootstrap.sh view
@@ -179,36 +179,52 @@ # The version regex says what existing installed versions are ok. PARSEC_VER="3.1.9";    PARSEC_VER_REGEXP="[3]\.[01]\."                        # >= 3.0 && < 3.2-DEEPSEQ_VER="1.4.1.1"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."+DEEPSEQ_VER="1.4.1.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."                        # >= 1.1 && < 2-BINARY_VER="0.7.2.3";  BINARY_VER_REGEXP="[0]\.[7]\."-                       # == 0.7.*-TEXT_VER="1.2.1.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"+BINARY_VER="0.8.2.1";  BINARY_VER_REGEXP="[0]\.[78]\."+                       # >= 0.7 && < 0.9+TEXT_VER="1.2.2.1";    TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))"                        # >= 0.2 && < 1.3-NETWORK_VER="2.6.2.0"; NETWORK_VER_REGEXP="2\.[0-6]\."+NETWORK_VER="2.6.2.1"; NETWORK_VER_REGEXP="2\.[0-6]\."                        # >= 2.0 && < 2.7-NETWORK_URI_VER="2.6.0.3"; NETWORK_URI_VER_REGEXP="2\.6\."+NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\."                        # >= 2.6 && < 2.7-CABAL_VER="1.23.0.0";  CABAL_VER_REGEXP="1\.23\."-                       # >= 1.23 && < 1.24-TRANS_VER="0.4.2.0";   TRANS_VER_REGEXP="0\.[4]\."-                       # >= 0.2.* && < 0.5+CABAL_VER="1.25.0.0";  CABAL_VER_REGEXP="1\.25\.[0-9]"+                       # >= 1.25 && < 1.26+TRANS_VER="0.5.2.0";   TRANS_VER_REGEXP="0\.[45]\."+                       # >= 0.2.* && < 0.6 MTL_VER="2.2.1";       MTL_VER_REGEXP="[2]\."                        #  >= 2.0 && < 3-HTTP_VER="4000.2.19";  HTTP_VER_REGEXP="4000\.2\.([5-9]|1[0-9]|2[0-9])"-                       # >= 4000.2.5 < 4000.3-ZLIB_VER="0.5.4.2";    ZLIB_VER_REGEXP="0\.[45]\."-                       # == 0.4.* || == 0.5.*-TIME_VER="1.5.0.1"     TIME_VER_REGEXP="1\.[12345]\.?"-                       # >= 1.1 && < 1.6+HTTP_VER="4000.3.3";   HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)"+                       # >= 4000.2.5 < 4000.4+ZLIB_VER="0.6.1.1";    ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)"+                       # >= 0.5.3 && <= 0.7+TIME_VER="1.6"         TIME_VER_REGEXP="1\.[1-6]\.?"+                       # >= 1.1 && < 1.7 RANDOM_VER="1.1"       RANDOM_VER_REGEXP="1\.[01]\.?"                        # >= 1 && < 1.2-STM_VER="2.4.4";       STM_VER_REGEXP="2\."+STM_VER="2.4.4.1";     STM_VER_REGEXP="2\."                        # == 2.*+ASYNC_VER="2.1.0";     ASYNC_VER_REGEXP="2\."+                       # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?"                        # >=1.0.0.0 && <1.2 OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?"                        # >=1.0.0.0 && <1.1+BYTEABLE_VER="0.1.1";  BYTEABLE_VER_REGEXP="0\.?"+                       # 0.1.1+CRYPTOHASH_VER="0.11.7"; CRYPTOHASH_VER_REGEXP="0\.11\.?"+                       # 0.11.*+ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"+                       # 0.0.*+HACKAGE_SECURITY_VER="0.5.0.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.?"+                       # >= 0.5 && < 0.6+TAR_VER="0.5.0.1";     TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.1)\.?"+                       # >= 0.5.0.1  && < 0.6+BASE64_BYTESTRING_VER="1.0.0.1";    BASE64_BYTESTRING_REGEXP="1\."+                                    # >=1.0+HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\."+                       # 1.*  HACKAGE_URL="https://hackage.haskell.org/package" @@ -255,24 +271,32 @@   PKG=$1   VER=$2 -  URL=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz+  URL_PKG=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz+  URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal   if which ${CURL} > /dev/null   then     # TODO: switch back to resuming curl command once     #       https://github.com/haskell/hackage-server/issues/111 is resolved-    #${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."-    ${CURL} -L --fail -O ${URL} || die "Failed to download ${PKG}."+    #${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL_PKG} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL_PKGDESC} \+        || die "Failed to download '${PKG}.cabal'."   elif which ${WGET} > /dev/null   then-    ${WGET} -c ${URL} || die "Failed to download ${PKG}."+    ${WGET} -c ${URL_PKG} || die "Failed to download ${PKG}."+    ${WGET} -c ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."   elif which ${FETCH} > /dev/null     then-      ${FETCH} ${URL} || die "Failed to download ${PKG}."+      ${FETCH} ${URL_PKG} || die "Failed to download ${PKG}."+      ${FETCH} ${URL_PKGDESC} || die "Failed to download '${PKG}.cabal'."   else     die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."   fi   [ -f "${PKG}-${VER}.tar.gz" ] ||-     die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+     die "Downloading ${URL_PKG} did not create ${PKG}-${VER}.tar.gz"+  [ -f "${PKG}.cabal" ] ||+     die "Downloading ${URL_PKGDESC} did not create ${PKG}.cabal"+  mv "${PKG}.cabal" "${PKG}.cabal.hackage" }  unpack_pkg () {@@ -282,6 +306,7 @@   rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"   ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf -   [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz"+  cp "${PKG}.cabal.hackage" "${PKG}-${VER}/${PKG}.cabal" }  install_pkg () {@@ -307,7 +332,8 @@    if [ ! ${NO_DOCUMENTATION} ]   then-    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} > /dev/null 2>&1+    if echo "${PKG}-${VER}" | egrep ${NO_DOCS_PACKAGES_VER_REGEXP} \+        > /dev/null 2>&1     then       echo "Skipping documentation for the ${PKG} package."     else@@ -356,8 +382,10 @@     do_pkg   "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}   else     # Use network < 2.6 && network-uri < 2.6-    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}+    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} \+        ${NETWORK_URI_DUMMY_VER_REGEXP}+    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} \+        ${NETWORK_URI_DUMMY_VER_REGEXP}   fi } @@ -373,11 +401,21 @@ info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP} info_pkg "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-info_pkg "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP}+info_pkg "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP} info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP} info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP}+info_pkg "async"        ${ASYNC_VER}   ${ASYNC_VER_REGEXP}+info_pkg "byteable"          ${BYTEABLE_VER}         ${BYTEABLE_VER_REGEXP}+info_pkg "cryptohash"        ${CRYPTOHASH_VER}       ${CRYPTOHASH_VER_REGEXP}+info_pkg "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}+info_pkg "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \+    ${BASE64_BYTESTRING_VER_REGEXP}+info_pkg "hashable"          ${HASHABLE_VER}          ${HASHABLE_VER_REGEXP}+info_pkg "hackage-security"  ${HACKAGE_SECURITY_VER} \+    ${HACKAGE_SECURITY_VER_REGEXP}  do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} do_pkg   "binary"       ${BINARY_VER}  ${BINARY_VER_REGEXP}@@ -393,11 +431,22 @@ do_network_uri_pkg  do_pkg   "old-locale"   ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP}-do_pkg   "old-time"     ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP}-do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP}-do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP}-do_pkg   "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}-do_pkg   "stm"          ${STM_VER}     ${STM_VER_REGEXP}+do_pkg   "old-time"     ${OLD_TIME_VER}   ${OLD_TIME_VER_REGEXP}+do_pkg   "HTTP"         ${HTTP_VER}       ${HTTP_VER_REGEXP}+do_pkg   "zlib"         ${ZLIB_VER}       ${ZLIB_VER_REGEXP}+do_pkg   "random"       ${RANDOM_VER}     ${RANDOM_VER_REGEXP}+do_pkg   "stm"          ${STM_VER}        ${STM_VER_REGEXP}+do_pkg   "async"        ${ASYNC_VER}      ${ASYNC_VER_REGEXP}+do_pkg   "byteable"          ${BYTEABLE_VER}         ${BYTEABLE_VER_REGEXP}+do_pkg   "cryptohash"        ${CRYPTOHASH_VER}       ${CRYPTOHASH_VER_REGEXP}+do_pkg   "ed25519"           ${ED25519_VER}          ${ED25519_VER_REGEXP}+do_pkg   "tar"               ${TAR_VER}              ${TAR_VER_REGEXP}+do_pkg   "base64-bytestring" ${BASE64_BYTESTRING_VER} \+    ${BASE64_BYTESTRING_VER_REGEXP}+do_pkg   "hashable"          ${HASHABLE_VER}         ${HASHABLE_VER_REGEXP}+do_pkg   "hackage-security"  ${HACKAGE_SECURITY_VER} \+    ${HACKAGE_SECURITY_VER_REGEXP}+  install_pkg "cabal-install"
cabal/cabal-install/cabal-install.cabal view
@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            1.23.0.0+Version:            1.25.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -21,13 +21,80 @@                     2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>                     2007-2012 Duncan Coutts <duncan@community.haskell.org> Category:           Distribution-Build-type:         Simple+Build-type:         Custom Cabal-Version:      >= 1.10 Extra-Source-Files:   README.md bash-completion/cabal bootstrap.sh changelog+  tests/README.md -  -- Generated with '../Cabal/misc/gen-extra-source-files.sh | sort'-  tests/PackageTests/Freeze/my.cabal+  -- Generated with '../Cabal/misc/gen-extra-source-files.sh'+  -- Do NOT edit this section manually; instead, run the script.+  -- BEGIN gen-extra-source-files+  tests/IntegrationTests/common.sh+  tests/IntegrationTests/custom/plain.err+  tests/IntegrationTests/custom/plain.sh+  tests/IntegrationTests/custom/plain/A.hs+  tests/IntegrationTests/custom/plain/Setup.hs+  tests/IntegrationTests/custom/plain/plain.cabal+  tests/IntegrationTests/exec/Foo.hs+  tests/IntegrationTests/exec/My.hs+  tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out+  tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh+  tests/IntegrationTests/exec/auto_configures_on_exec.out+  tests/IntegrationTests/exec/auto_configures_on_exec.sh+  tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out+  tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh+  tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh+  tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh+  tests/IntegrationTests/exec/exit_with_failure_without_args.err+  tests/IntegrationTests/exec/exit_with_failure_without_args.sh+  tests/IntegrationTests/exec/my.cabal+  tests/IntegrationTests/exec/runs_given_command.out+  tests/IntegrationTests/exec/runs_given_command.sh+  tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh+  tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh+  tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh+  tests/IntegrationTests/freeze/does_not_freeze_self.sh+  tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh+  tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh+  tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh+  tests/IntegrationTests/freeze/freezes_direct_dependencies.sh+  tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh+  tests/IntegrationTests/freeze/my.cabal+  tests/IntegrationTests/freeze/runs_without_error.sh+  tests/IntegrationTests/internal-libs/internal_lib_basic.sh+  tests/IntegrationTests/internal-libs/internal_lib_shadow.sh+  tests/IntegrationTests/internal-libs/p/Foo.hs+  tests/IntegrationTests/internal-libs/p/p.cabal+  tests/IntegrationTests/internal-libs/p/p/P.hs+  tests/IntegrationTests/internal-libs/p/q/Q.hs+  tests/IntegrationTests/internal-libs/q/Q.hs+  tests/IntegrationTests/internal-libs/q/q.cabal+  tests/IntegrationTests/manpage/outputs_manpage.sh+  tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh+  tests/IntegrationTests/multiple-source/p/Setup.hs+  tests/IntegrationTests/multiple-source/p/p.cabal+  tests/IntegrationTests/multiple-source/q/Setup.hs+  tests/IntegrationTests/multiple-source/q/q.cabal+  tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err+  tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh+  tests/IntegrationTests/sandbox-sources/p/Setup.hs+  tests/IntegrationTests/sandbox-sources/p/p.cabal+  tests/IntegrationTests/sandbox-sources/q/Setup.hs+  tests/IntegrationTests/sandbox-sources/q/q.cabal+  tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh+  tests/IntegrationTests/sandbox-sources/report_success_removing_source.out+  tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh+  tests/IntegrationTests/user-config/common.sh+  tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err+  tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh+  tests/IntegrationTests/user-config/overwrites_with_f.out+  tests/IntegrationTests/user-config/overwrites_with_f.sh+  tests/IntegrationTests/user-config/runs_without_error.out+  tests/IntegrationTests/user-config/runs_without_error.sh+  tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out+  tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh+  -- END gen-extra-source-files  source-repository head   type:     git@@ -45,6 +112,11 @@ executable cabal     main-is:        Main.hs     ghc-options:    -Wall -fwarn-tabs+    if impl(ghc >= 8.0)+        ghc-options: -Wcompat+                     -Wnoncanonical-monad-instances+                     -Wnoncanonical-monadfail-instances+     other-modules:         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage@@ -64,6 +136,7 @@         Distribution.Client.Dependency.Modular.Builder         Distribution.Client.Dependency.Modular.Configured         Distribution.Client.Dependency.Modular.ConfiguredConversion+        Distribution.Client.Dependency.Modular.Cycles         Distribution.Client.Dependency.Modular.Dependency         Distribution.Client.Dependency.Modular.Explore         Distribution.Client.Dependency.Modular.Flag@@ -79,11 +152,16 @@         Distribution.Client.Dependency.Modular.Tree         Distribution.Client.Dependency.Modular.Validate         Distribution.Client.Dependency.Modular.Version+        Distribution.Client.DistDirLayout         Distribution.Client.Exec         Distribution.Client.Fetch         Distribution.Client.FetchUtils+        Distribution.Client.FileMonitor         Distribution.Client.Freeze+        Distribution.Client.GenBounds         Distribution.Client.Get+        Distribution.Client.Glob+        Distribution.Client.GlobalFlags         Distribution.Client.GZipUtils         Distribution.Client.Haddock         Distribution.Client.HttpUtils@@ -97,16 +175,26 @@         Distribution.Client.InstallSymlink         Distribution.Client.JobControl         Distribution.Client.List+        Distribution.Client.Manpage+        Distribution.Client.PackageHash         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils+        Distribution.Client.PkgConfigDb         Distribution.Client.PlanIndex+        Distribution.Client.ProjectBuilding+        Distribution.Client.ProjectConfig+        Distribution.Client.ProjectConfig.Types+        Distribution.Client.ProjectConfig.Legacy+        Distribution.Client.ProjectPlanning         Distribution.Client.Run+        Distribution.Client.RebuildMonad         Distribution.Client.Sandbox         Distribution.Client.Sandbox.Index         Distribution.Client.Sandbox.PackageEnvironment         Distribution.Client.Sandbox.Timestamp         Distribution.Client.Sandbox.Types+        Distribution.Client.Security.HTTP         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist@@ -129,48 +217,54 @@     -- NOTE: when updating build-depends, don't forget to update version regexps     -- in bootstrap.sh.     build-depends:-        array      >= 0.1      && < 0.6,-        base       >= 4.3      && < 5,+        async      >= 2.0      && < 3,+        array      >= 0.4      && < 0.6,+        base       >= 4.5      && < 5,+        binary     >= 0.5      && < 0.9,+        byteable   >= 0.1      && < 0.2,         bytestring >= 0.9      && < 1,-        Cabal      >= 1.23     && < 1.24,-        containers >= 0.1      && < 0.6,-        filepath   >= 1.0      && < 1.5,-        HTTP       >= 4000.1.5 && < 4000.3,+        Cabal      >= 1.25     && < 1.26,+        containers >= 0.4      && < 0.6,+        cryptohash >= 0.11     && < 0.12,+        filepath   >= 1.3      && < 1.5,+        hashable   >= 1.0      && < 2,+        HTTP       >= 4000.1.5 && < 4000.4,         mtl        >= 2.0      && < 3,-        pretty     >= 1        && < 1.2,+        pretty     >= 1.1      && < 1.2,         random     >= 1        && < 1.2,         stm        >= 2.0      && < 3,-        time       >= 1.1      && < 1.6,-        zlib       >= 0.5.3    && < 0.7+        tar        >= 0.5.0.1  && < 0.6,+        time       >= 1.4      && < 1.7,+        zlib       >= 0.5.3    && < 0.7,+        hackage-security >= 0.5 && < 0.6      if flag(old-directory)-      build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2,+      build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,                      process   >= 1.0.1.1  && < 1.1.0.2     else       build-depends: directory >= 1.2 && < 1.3,-                     process   >= 1.1.0.2  && < 1.4+                     process   >= 1.1.0.2  && < 1.5      -- NOTE: you MUST include the network dependency even when network-uri     -- is pulled in, otherwise the constraint solver doesn't have enough     -- information     if flag(network-uri)-      build-depends: network-uri >= 2.6, network >= 2.6+      build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.7     else       build-depends: network     >= 2.4 && < 2.6 +    -- Needed for GHC.Generics before GHC 7.6+    if impl(ghc < 7.6)+      build-depends: ghc-prim >= 0.2 && < 0.3+     if os(windows)       build-depends: Win32 >= 2 && < 3-      cpp-options: -DWIN32     else-      build-depends: unix >= 2.0 && < 2.8+      build-depends: unix >= 2.5 && < 2.8 -    if arch(arm) && impl(ghc < 7.6)-       -- older ghc on arm does not support -threaded-       cc-options:  -DCABAL_NO_THREADED-    else-       ghc-options: -threaded+    if !(arch(arm) && impl(ghc < 7.6))+      ghc-options: -threaded -    c-sources: cbits/getnumcores.c     default-language: Haskell2010  -- Small, fast running tests.@@ -180,13 +274,21 @@   hs-source-dirs: tests, .   ghc-options: -Wall -fwarn-tabs   other-modules:+    UnitTests.Distribution.Client.ArbitraryInstances     UnitTests.Distribution.Client.Targets+    UnitTests.Distribution.Client.Compat.Time     UnitTests.Distribution.Client.Dependency.Modular.PSQ     UnitTests.Distribution.Client.Dependency.Modular.Solver     UnitTests.Distribution.Client.Dependency.Modular.DSL+    UnitTests.Distribution.Client.FileMonitor+    UnitTests.Distribution.Client.Glob     UnitTests.Distribution.Client.GZipUtils     UnitTests.Distribution.Client.Sandbox+    UnitTests.Distribution.Client.Sandbox.Timestamp+    UnitTests.Distribution.Client.Tar     UnitTests.Distribution.Client.UserConfig+    UnitTests.Distribution.Client.ProjectConfig+    UnitTests.Options   build-depends:         base,         array,@@ -198,16 +300,20 @@         process,         directory,         filepath,+        hashable,         stm,+        tar,         time,         HTTP,         zlib,+        binary,         random,+        hackage-security,         tasty,         tasty-hunit,         tasty-quickcheck,         tagged,-        QuickCheck >= 2.5+        QuickCheck >= 2.8.2    if flag(old-directory)     build-depends: old-time@@ -217,52 +323,101 @@   else     build-depends: network-uri < 2.6, network < 2.6 +  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3+   if os(windows)     build-depends: Win32-    cpp-options: -DWIN32   else     build-depends: unix -  if arch(arm)-    cc-options:  -DCABAL_NO_THREADED+  if !(arch(arm) && impl(ghc < 7.6))+    ghc-options: -threaded+  default-language: Haskell2010++-- Slow solver tests+Test-Suite solver-quickcheck+  type: exitcode-stdio-1.0+  main-is: SolverQuickCheck.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs+  other-modules:+    UnitTests.Distribution.Client.Dependency.Modular.DSL+    UnitTests.Distribution.Client.Dependency.Modular.QuickCheck+  build-depends:+        base,+        array,+        bytestring,+        Cabal,+        containers,+        mtl,+        pretty,+        process,+        directory,+        filepath,+        hashable,+        stm,+        tar,+        time,+        HTTP,+        zlib,+        binary,+        random,+        hackage-security,+        tasty,+        tasty-quickcheck,+        QuickCheck >= 2.8.2,+        pretty-show++  if flag(old-directory)+    build-depends: old-time++  if flag(network-uri)+    build-depends: network-uri >= 2.6, network >= 2.6   else+    build-depends: network-uri < 2.6, network < 2.6++  if impl(ghc < 7.6)+    build-depends: ghc-prim >= 0.2 && < 0.3++  if os(windows)+    build-depends: Win32+  else+    build-depends: unix++  if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded   default-language: Haskell2010 --- Large, system tests that build packages.-test-suite package-tests+test-suite integration-tests   type: exitcode-stdio-1.0   hs-source-dirs: tests-  main-is: PackageTests.hs-  other-modules:-    PackageTests.Exec.Check-    PackageTests.Freeze.Check-    PackageTests.MultipleSource.Check-    PackageTests.PackageTester+  main-is: IntegrationTests.hs   build-depends:     Cabal,-    QuickCheck >= 2.1.0.1 && < 2.9,+    async,     base,     bytestring,     directory,-    extensible-exceptions,     filepath,     process,     regex-posix,     tasty,-    tasty-hunit,-    tasty-quickcheck+    tasty-hunit    if os(windows)     build-depends: Win32 >= 2 && < 3-    cpp-options: -DWIN32   else-    build-depends: unix >= 2.0 && < 2.8+    build-depends: unix >= 2.5 && < 2.8 -  if arch(arm)-    cc-options:  -DCABAL_NO_THREADED-  else+  if !(arch(arm) && impl(ghc < 7.6))     ghc-options: -threaded    ghc-options: -Wall   default-language: Haskell2010++custom-setup+  setup-depends: Cabal >= 1.25,+                 base,+                 process   >= 1.1.0.1  && < 1.5,+                 filepath   >= 1.3      && < 1.5
− cabal/cabal-install/cbits/getnumcores.c 
@@ -1,46 +0,0 @@-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612) && !defined(CABAL_NO_THREADED)-/* Since version 6.12, GHC's threaded RTS includes a getNumberOfProcessors-   function, so we try to use that if available. cabal-install is always built-   with -threaded nowadays.  */-#define HAS_GET_NUMBER_OF_PROCESSORS-#endif---#ifndef HAS_GET_NUMBER_OF_PROCESSORS--#ifdef _WIN32-#include <windows.h>-#elif MACOS-#include <sys/param.h>-#include <sys/sysctl.h>-#elif __linux__-#include <unistd.h>-#endif--int getNumberOfProcessors() {-#ifdef WIN32-    SYSTEM_INFO sysinfo;-    GetSystemInfo(&sysinfo);-    return sysinfo.dwNumberOfProcessors;-#elif MACOS-    int nm[2];-    size_t len = 4;-    uint32_t count;--    nm[0] = CTL_HW; nm[1] = HW_AVAILCPU;-    sysctl(nm, 2, &count, &len, NULL, 0);--    if(count < 1) {-        nm[1] = HW_NCPU;-        sysctl(nm, 2, &count, &len, NULL, 0);-        if(count < 1) { count = 1; }-    }-    return count;-#elif __linux__-    return sysconf(_SC_NPROCESSORS_ONLN);-#else-    return 1;-#endif-}--#endif /* HAS_GET_NUMBER_OF_PROCESSORS */
cabal/cabal-install/changelog view
@@ -1,6 +1,9 @@ -*-change-log-*- -1.23.x.x (current development version)+1.25.x.x (current development version)+	* Made the solver aware of pkg-config constraints (#3023).++1.24.0.0 Ryan Thomas <ryan@ryant.org> March 2016 	* If there are multiple remote repos, 'cabal update' now updates 	them in parallel (#2503). 	* New 'cabal upload' option '-P'/'--password-command' for reading@@ -18,13 +21,44 @@ 	* Automatically use https for cabal upload for the main 	hackage.haskell.org (other repos will use whatever they are 	configured to use).-	* Support for dependencies of custom Setup.hs scripts.+	* Support for dependencies of custom Setup.hs scripts+	(see http://www.well-typed.com/blog/2015/07/cabal-setup-deps/). 	* 'cabal' program itself now can be used as an external setup 	method. This fixes an issue when Cabal version mismatch caused 	unnecessary reconfigures (#2633). 	* Improved error message for unsatisfiable package constraints 	(#2727). 	* Fixed a space leak in 'cabal update' (#2826).+	* 'cabal exec' and 'sandbox hc-pkg' now use the configured+	compiler (#2859).+	* New 'cabal haddock' option: '--for-hackage' (#2852).+	* Added a warning when the solver cannot find a dependency (#2853).+	* New 'cabal upload' option: '--doc': upload documentation to+	hackage (#2890).+	* Improved error handling for 'sandbox delete-source' (#2943).+	* Solver support for extension and language flavours (#2873).+	* Support for secure repos using hackage-security (#2983).+	* Added a log file message similar to one printed by 'make' when+	building in another directory (#2642).+	* Added new subcommand 'init' to 'cabal user-config'. This+	subcommand creates a cabal configuration file in either the+	default location or as specified by --config-file (#2553).+	* The man page for 'cabal-install' is now automatically generated+	(#2877).+	* The '--allow-newer' option now works as expected when specified+	multiple times (#2588).+	* New config file field: 'extra-framework-dirs' (extra locations+	to find OS X frameworks in). Can be also specified as an argument+	for 'install' and 'configure' commands (#3158).+	* It's now possible to limit the scope of '--allow-newer' to+	single packages in the install plan (#2756).+	* Full '--allow-newer' syntax is now supported in the config file+	(that is, 'allow-newer: base, ghc-prim,  some-package:vector')+	(#3171).+	* Improved performance of '--reorder-goals' (#3208).+	* Fixed space leaks in modular solver (#2916, #2914).+	* Added a new command: 'gen-bounds' (#3223). See+	http://softwaresimply.blogspot.se/2015/08/cabal-gen-bounds-easy-generation-of.html.  1.22.0.0 Johan Tibell <johan.tibell@gmail.com> January 2015 	* New command: user-config (#2159).
+ cabal/cabal-install/tests/IntegrationTests.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE CPP #-}+-- | Groups black-box tests of cabal-install and configures them to test+-- the correct binary.+--+-- This file should do nothing but import tests from other modules and run+-- them with the path to the correct cabal-install binary.+module Main+       where++-- Modules from Cabal.+import Distribution.Compat.CreatePipe (createPipe)+import Distribution.Compat.Environment (setEnv)+import Distribution.Compat.Internal.TempFile (createTempDirectory)+import Distribution.Simple.Configure (findDistPrefOrDefault)+import Distribution.Simple.Program.Builtin (ghcPkgProgram)+import Distribution.Simple.Program.Db+        (defaultProgramDb, requireProgram, setProgramSearchPath)+import Distribution.Simple.Program.Find+        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)+import Distribution.Simple.Program.Types+        ( Program(..), simpleProgram, programPath)+import Distribution.Simple.Setup ( Flag(..) )+import Distribution.Simple.Utils ( findProgramVersion, copyDirectoryRecursive, installOrdinaryFile )+import Distribution.Verbosity (normal)++-- Third party modules.+import Control.Concurrent.Async (withAsync, wait)+import Control.Exception (bracket)+import Data.Maybe (fromMaybe)+import System.Directory+        ( canonicalizePath+        , findExecutable+        , getDirectoryContents+        , getTemporaryDirectory+        , doesDirectoryExist+        , removeDirectoryRecursive+        , doesFileExist )+import System.FilePath+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (testCase, Assertion, assertFailure)+import Control.Monad ( filterM, forM, unless, when )+import Data.List (isPrefixOf, isSuffixOf, sort)+import Data.IORef (newIORef, writeIORef, readIORef)+import System.Exit (ExitCode(..))+import System.IO (withBinaryFile, IOMode(ReadMode))+import System.Process (runProcess, waitForProcess)+import Text.Regex.Posix ((=~))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import           Data.ByteString (ByteString)++#if MIN_VERSION_base(4,6,0)+import System.Environment ( getExecutablePath )+#endif++-- | Test case.+data TestCase = TestCase+    { tcName :: String -- ^ Name of the shell script+    , tcBaseDirectory :: FilePath -- ^ The base directory where tests are found+                                  --   e.g., cabal-install/tests/IntegrationTests+    , tcCategory :: String -- ^ Category of test; e.g., custom, exec, freeze, ...+    , tcStdOutPath :: Maybe FilePath -- ^ File path of expected standard output+    , tcStdErrPath :: Maybe FilePath -- ^ File path of expected standard error+    }++-- | Test result.+data TestResult = TestResult+    { trExitCode :: ExitCode -- ^ Exit code of test script+    , trStdOut :: ByteString -- ^ Actual standard output+    , trStdErr :: ByteString -- ^ Actual standard error+    , trWorkingDirectory :: FilePath -- ^ Temporary working directory test was+                                     --   executed in.+    }++-- | Cabal executable+cabalProgram :: Program+cabalProgram = (simpleProgram "cabal") {+    programFindVersion = findProgramVersion "--numeric-version" id+  }++-- | Convert test result to user-friendly string message.+testResultToString :: TestResult -> String+testResultToString testResult =+    exitStatus ++ "\n" ++ workingDirectory ++ "\n\n" ++ stdOut ++ "\n\n" ++ stdErr+  where+    exitStatus = "Exit status: " ++ show (trExitCode testResult)+    workingDirectory = "Working directory: " ++ (trWorkingDirectory testResult)+    stdOut = "<stdout> was:\n" ++ C8.unpack (trStdOut testResult)+    stdErr = "<stderr> was:\n" ++ C8.unpack (trStdErr testResult)++-- | Returns the command that was issued, the return code, and the output text+run :: FilePath -> String -> [String] -> IO TestResult+run cwd path args = do+  -- path is relative to the current directory; canonicalizePath makes it+  -- absolute, so that runProcess will find it even when changing directory.+  path' <- canonicalizePath path++  (pid, hReadStdOut, hReadStdErr) <- do+    -- Create pipes for StdOut and StdErr+    (hReadStdOut, hWriteStdOut) <- createPipe+    (hReadStdErr, hWriteStdErr) <- createPipe+    -- Run the process+    pid <- runProcess path' args (Just cwd) Nothing Nothing (Just hWriteStdOut) (Just hWriteStdErr)+    -- Return the pid and read ends of the pipes+    return (pid, hReadStdOut, hReadStdErr)+  -- Read subprocess output using asynchronous threads; we need to+  -- do this aynchronously to avoid deadlocks due to buffers filling+  -- up.+  withAsync (B.hGetContents hReadStdOut) $ \stdOutAsync -> do+    withAsync (B.hGetContents hReadStdErr) $ \stdErrAsync -> do+      -- Wait for the subprocess to terminate+      exitcode <- waitForProcess pid+      -- We can now be sure that no further output is going to arrive,+      -- so we wait for the results of the asynchronous reads.+      stdOut <- wait stdOutAsync+      stdErr <- wait stdErrAsync+      -- Done+      return $ TestResult exitcode stdOut stdErr cwd++-- | Get a list of all names in a directory, excluding all hidden or+-- system files/directories such as '.', '..'  or any files/directories+-- starting with a '.'.+listDirectory :: FilePath -> IO [String]+listDirectory directory = do+  fmap (filter notHidden) $ getDirectoryContents directory+  where+    notHidden = not . isHidden+    isHidden name = "." `isPrefixOf` name++-- | List a directory as per 'listDirectory', but return an empty list+-- in case the directory does not exist.+listDirectoryLax :: FilePath -> IO [String]+listDirectoryLax directory = do+  d <- doesDirectoryExist directory+  if d then+    listDirectory directory+  else+    return [ ]++-- | @pathIfExists p == return (Just p)@ if @p@ exists, and+-- @return Nothing@ otherwise.+pathIfExists :: FilePath -> IO (Maybe FilePath)+pathIfExists p = do+  e <- doesFileExist p+  if e then+    return $ Just p+    else+      return Nothing++-- | Checks if file @p@ matches a 'ByteString' @s@, subject+-- to line-break normalization.  Lines in the file which are+-- prefixed with @RE:@ are treated specially as a regular expression.+fileMatchesString :: FilePath -> ByteString -> IO Bool+fileMatchesString p s = do+  withBinaryFile p ReadMode $ \h -> do+    expected <- (C8.lines . normalizeLinebreaks) `fmap` B.hGetContents h -- Strict+    let actual = C8.lines $ normalizeLinebreaks s+    return $ length expected == length actual &&+             and (zipWith matches expected actual)+  where+    matches :: ByteString -> ByteString -> Bool+    matches pattern line+        | C8.pack "RE:" `B.isPrefixOf` pattern = line =~ C8.drop 3 pattern+        | otherwise                            = line == pattern++    -- This is a bit of a hack, but since we're comparing+    -- *text* output, we should be OK.+    normalizeLinebreaks = B.filter (not . ((==) 13)) -- carriage return++-- | Check if the @actual@ 'ByteString' matches the contents of+-- @expected@ (always succeeds if the expectation is 'Nothing').+-- Also takes the 'TestResult' and a label @handleName@ describing+-- what text the string values correspond to.+mustMatch :: TestResult -> String -> ByteString -> Maybe FilePath -> Assertion+mustMatch _          _          _      Nothing         =  return ()+mustMatch testResult handleName actual (Just expected) = do+  m <- fileMatchesString expected actual+  unless m $ assertFailure $+      "<" ++ handleName ++ "> did not match file '"+      ++ expected ++ "'.\n" ++ testResultToString testResult++-- | Given a @directory@, return its subdirectories.  This is+-- run on @cabal-install/tests/IntegrationTests@ to get the+-- list of test categories which can be run.+discoverTestCategories :: FilePath -> IO [String]+discoverTestCategories directory = do+  names <- listDirectory directory+  fmap sort $ filterM (\name -> doesDirectoryExist $ directory </> name) names++-- | Find all shell scripts in @baseDirectory </> category@.+discoverTestCases :: FilePath -> String -> IO [TestCase]+discoverTestCases baseDirectory category = do+  -- Find the names of the shell scripts+  names <- fmap (filter isTestCase) $ listDirectoryLax directory+  -- Fill in TestCase for each script+  forM (sort names) $ \name -> do+    stdOutPath <- pathIfExists $ directory </> name `replaceExtension` ".out"+    stdErrPath <- pathIfExists $ directory </> name `replaceExtension` ".err"+    return $ TestCase { tcName = name+                      , tcBaseDirectory = baseDirectory+                      , tcCategory = category+                      , tcStdOutPath = stdOutPath+                      , tcStdErrPath = stdErrPath+                      }+  where+    directory = baseDirectory </> category+    isTestCase name = ".sh" `isSuffixOf` name++-- | Given a list of 'TestCase's (describing a shell script for a+-- single test case), run @mk@ on each of them to form a runnable+-- 'TestTree'.+createTestCases :: [TestCase] -> (TestCase -> Assertion) -> IO [TestTree]+createTestCases testCases mk =+  return $ (flip map) testCases $ \tc -> testCase (tcName tc ++ suffix tc) $ mk tc+  where+    suffix tc = case (tcStdOutPath tc, tcStdErrPath tc) of+      (Nothing, Nothing) -> " (ignoring stdout+stderr)"+      (Just _ , Nothing) -> " (ignoring stderr)"+      (Nothing, Just _ ) -> " (ignoring stdout)"+      (Just _ , Just _ ) -> ""++-- | Given a 'TestCase', run it.+--+-- A test case of the form @category/testname.sh@ is+-- run in the following way+--+--      1. We make a full copy all of @category@ into a temporary+--         directory.+--      2. In the temporary directory, run @testname.sh@.+--      3. Test that the exit code is zero, and that stdout/stderr+--         match the expected results.+--+runTestCase :: TestCase -> IO ()+runTestCase tc = do+  doRemove <- newIORef False+  bracket createWorkDirectory (removeWorkDirectory doRemove) $ \workDirectory -> do+    -- Run+    let scriptDirectory = workDirectory+    sh <- fmap (fromMaybe $ error "Cannot find 'sh' executable") $ findExecutable "sh"+    testResult <- run scriptDirectory sh [ "-e", tcName tc]+    -- Assert that we got what we expected+    case trExitCode testResult of+      ExitSuccess ->+        return () -- We're good+      ExitFailure _ ->+        assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult+    mustMatch testResult "stdout" (trStdOut testResult) (tcStdOutPath tc)+    mustMatch testResult "stderr" (trStdErr testResult) (tcStdErrPath tc)+    -- Only remove working directory if test succeeded+    writeIORef doRemove True+  where+    createWorkDirectory = do+      -- Create the temporary directory+      tempDirectory <- getTemporaryDirectory+      workDirectory <- createTempDirectory tempDirectory "cabal-install-test"+      -- Copy all the files from the category into the working directory.+      copyDirectoryRecursive normal+        (tcBaseDirectory tc </> tcCategory tc)+        workDirectory+      -- Copy in the common.sh stub+      let commonDest = workDirectory </> "common.sh"+      e <- doesFileExist commonDest+      unless e $+        installOrdinaryFile normal (tcBaseDirectory tc </> "common.sh") commonDest+      -- Done+      return workDirectory+    removeWorkDirectory doRemove workDirectory = do+        remove <- readIORef doRemove+        when remove $ removeDirectoryRecursive workDirectory++discoverCategoryTests :: FilePath -> String -> IO [TestTree]+discoverCategoryTests baseDirectory category = do+  testCases <- discoverTestCases baseDirectory category+  createTestCases testCases runTestCase++main :: IO ()+main = do+  -- Find executables and build directories, etc.+  distPref <- guessDistDir+  buildDir <- canonicalizePath (distPref </> "build/cabal")+  let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath+  (cabal, _) <- requireProgram normal cabalProgram (setProgramSearchPath programSearchPath defaultProgramDb)+  (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb+  baseDirectory <- canonicalizePath $ "tests" </> "IntegrationTests"+  -- Set up environment variables for test scripts+  setEnv "GHC_PKG" $ programPath ghcPkg+  setEnv "CABAL" $ programPath cabal+  -- Define default arguments+  setEnv "CABAL_ARGS" $ "--config-file=config-file"+  setEnv "CABAL_ARGS_NO_CONFIG_FILE" " "+  -- Discover all the test categories+  categories <- discoverTestCategories baseDirectory+  -- Discover tests in each category+  tests <- forM categories $ \category -> do+    categoryTests <- discoverCategoryTests baseDirectory category+    return (category, categoryTests)+  -- Map into a test tree+  let testTree = map (\(category, categoryTests) -> testGroup category categoryTests) tests+  -- Run the tests+  defaultMain $ testGroup "Integration Tests" $ testTree++-- See this function in Cabal's PackageTests. If you update this,+-- update its copy in cabal-install.  (Why a copy here? I wanted+-- to try moving this into the Cabal library, but to do this properly+-- I'd have to BC'ify getExecutablePath, and then it got hairy, so+-- I aborted and did something simple.)+guessDistDir :: IO FilePath+guessDistDir = do+#if MIN_VERSION_base(4,6,0)+    exe_path <- canonicalizePath =<< getExecutablePath+    let dist0 = dropFileName exe_path </> ".." </> ".."+    b <- doesFileExist (dist0 </> "setup-config")+#else+    let dist0 = error "no path"+        b = False+#endif+    -- Method (2)+    if b then canonicalizePath dist0+         else findDistPrefOrDefault NoFlag >>= canonicalizePath
+ cabal/cabal-install/tests/IntegrationTests/common.sh view
@@ -0,0 +1,12 @@+# A globally available set of useful utilities.  Test+# scripts can include this by saying ". ./common.sh"++# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ cabal/cabal-install/tests/IntegrationTests/custom/plain.err view
@@ -0,0 +1,2 @@+Custom+Custom
+ cabal/cabal-install/tests/IntegrationTests/custom/plain.sh view
@@ -0,0 +1,4 @@+. ./common.sh+cd plain+cabal configure+cabal build
+ cabal/cabal-install/tests/IntegrationTests/custom/plain/A.hs view
@@ -0,0 +1,1 @@+module A where
+ cabal/cabal-install/tests/IntegrationTests/custom/plain/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+import System.IO+main = hPutStrLn stderr "Custom" >> defaultMain
+ cabal/cabal-install/tests/IntegrationTests/custom/plain/plain.cabal view
@@ -0,0 +1,12 @@+name:                plain+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Custom+cabal-version:       >=1.10++library+  exposed-modules:     A+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/exec/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++foo :: String+foo = "foo"
+ cabal/cabal-install/tests/IntegrationTests/exec/My.hs view
@@ -0,0 +1,5 @@+module Main where++main :: IO ()+main = do+    putStrLn "This is my-executable"
+ cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out view
@@ -0,0 +1,1 @@+This is my-executable
+ cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh view
@@ -0,0 +1,10 @@+. ./common.sh++cabal sandbox delete > /dev/null+cabal exec my-executable && die "Unexpectedly found executable"++cabal sandbox init > /dev/null+cabal install > /dev/null++# Execute indirectly via bash to ensure that we go through $PATH+cabal exec sh -- -c my-executable || die "Did not find executable"
+ cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.out view
@@ -0,0 +1,4 @@+Config file path source is commandline option.+Config file config-file not found.+Writing default configuration to config-file+find_me_in_output
+ cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.sh view
@@ -0,0 +1,2 @@+. ./common.sh+cabal exec echo find_me_in_output
+ cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out view
@@ -0,0 +1,1 @@+This is my-executable
+ cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh view
@@ -0,0 +1,9 @@+. ./common.sh++cabal sandbox delete > /dev/null+cabal exec my-executable && die "Unexpectedly found executable"++cabal sandbox init > /dev/null+cabal install > /dev/null++cabal exec my-executable || die "Did not find executable"
+ cabal/cabal-install/tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh view
@@ -0,0 +1,14 @@+. ./common.sh++cabal sandbox delete > /dev/null+cabal exec my-executable && die "Unexpectedly found executable"++cabal sandbox init > /dev/null+cabal install > /dev/null++# The library should not be available outside the sandbox+"$GHC_PKG" list | grep -v "my-0.1"++# When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command+# should find the library.+cabal exec sh -- -c 'cd subdir && "$CABAL" sandbox hc-pkg list' | grep "my-0.1"
+ cabal/cabal-install/tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh view
@@ -0,0 +1,13 @@+. ./common.sh++cabal sandbox delete > /dev/null+cabal exec my-executable && die "Unexpectedly found executable"++cabal sandbox init > /dev/null+cabal install > /dev/null++# The library should not be available outside the sandbox+"$GHC_PKG" list | grep -v "my-0.1"++# Execute ghc-pkg inside the sandbox; it should find my-0.1+cabal exec ghc-pkg list | grep "my-0.1"
+ cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.err view
@@ -0,0 +1,1 @@+RE:^cabal(\.exe)?: Please specify an executable to run$
+ cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.sh view
@@ -0,0 +1,3 @@+. ./common.sh++! cabal exec
+ cabal/cabal-install/tests/IntegrationTests/exec/my.cabal view
@@ -0,0 +1,14 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.2+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base+++executable my-executable+    main-is:            My.hs+    build-depends:      base
+ cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.out view
@@ -0,0 +1,1 @@+this string
+ cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal configure > /dev/null+cabal exec echo this string
+ cabal/cabal-install/tests/IntegrationTests/exec/subdir/.gitkeep view
+ cabal/cabal-install/tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze --disable-benchmarks+grep -v " criterion ==" cabal.config || die "should NOT have frozen criterion"
+ cabal/cabal-install/tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze --disable-tests+grep -v " test-framework ==" cabal.config || die "should NOT have frozen test-framework"
+ cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh view
@@ -0,0 +1,5 @@+. ./common.sh+# TODO: Test this against a package installed in the sandbox but not+# depended upon.+cabal freeze+grep -v "exceptions ==" cabal.config || die "should not have frozen exceptions"
+ cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_self.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze+grep -v " my ==" cabal.config || die "should not have frozen self"
+ cabal/cabal-install/tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze --dry-run+[ ! -e cabal.config ] || die "cabal.config file should not have been created"
+ cabal/cabal-install/tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh view
@@ -0,0 +1,4 @@+. ./common.sh+# TODO: solver should find solution without extra flags too+cabal freeze --enable-benchmarks --reorder-goals --max-backjumps=-1+grep " criterion ==" cabal.config || die "should have frozen criterion"
+ cabal/cabal-install/tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze --enable-tests+grep " test-framework ==" cabal.config || die "should have frozen test-framework"
+ cabal/cabal-install/tests/IntegrationTests/freeze/freezes_direct_dependencies.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze+grep " base ==" cabal.config || die "'base' should have been frozen"
+ cabal/cabal-install/tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh view
@@ -0,0 +1,3 @@+. ./common.sh+cabal freeze+grep " ghc-prim ==" cabal.config || die "'ghc-prim' should have been frozen"
+ cabal/cabal-install/tests/IntegrationTests/freeze/my.cabal view
@@ -0,0 +1,21 @@+name:           my+version:        0.1+license:        BSD3+cabal-version:  >= 1.20.0+build-type:     Simple++library+    exposed-modules:    Foo+    build-depends:      base++test-suite test-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is:    test-Foo.hs+    build-depends: base, my, test-framework++benchmark bench-Foo+    type:   exitcode-stdio-1.0+    hs-source-dirs: benchmarks+    main-is:    benchmark-Foo.hs+    build-depends: base, my, criterion
+ cabal/cabal-install/tests/IntegrationTests/freeze/runs_without_error.sh view
@@ -0,0 +1,2 @@+. ./common.sh+cabal freeze
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_basic.sh view
@@ -0,0 +1,5 @@+. ./common.sh++cabal sandbox init+cabal sandbox add-source p+cabal install p
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_shadow.sh view
@@ -0,0 +1,6 @@+. ./common.sh++cabal sandbox init+cabal sandbox add-source p+cabal sandbox add-source q+cabal install p
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/p/Foo.hs view
@@ -0,0 +1,2 @@+import Q+main = putStrLn q
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p.cabal view
@@ -0,0 +1,23 @@+name:                p+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.23++library q+  build-depends:       base+  exposed-modules:     Q+  hs-source-dirs:      q+  default-language:    Haskell2010++library+  build-depends:       base, q+  exposed-modules:     P+  hs-source-dirs:      p+  default-language:    Haskell2010++executable foo+  build-depends:       base, q+  main-is:             Foo.hs
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p/P.hs view
@@ -0,0 +1,2 @@+module P where+import Q
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/p/q/Q.hs view
@@ -0,0 +1,2 @@+module Q where+q = "I AM THE ONE"
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/q/Q.hs view
@@ -0,0 +1,2 @@+module Q where+q = "DO NOT SEE ME"
+ cabal/cabal-install/tests/IntegrationTests/internal-libs/q/q.cabal view
@@ -0,0 +1,12 @@+name:                q+version:             0.1.0.0+license:             BSD3+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Q+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/manpage/outputs_manpage.sh view
@@ -0,0 +1,11 @@+. ./common.sh++OUTPUT=`cabal manpage`++# contains visible command descriptions+echo $OUTPUT | grep -q '\.B cabal install' || die "visible command description line not found in:\n----$OUTPUT\n----"++# does not contain hidden command descriptions+echo $OUTPUT | grep -q '\.B cabal manpage' && die "hidden command description line found in:\n----$OUTPUT\n----"++exit 0
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh view
@@ -0,0 +1,11 @@+. ./common.sh++# Create the sandbox+cabal sandbox init++# Add the sources+cabal sandbox add-source p+cabal sandbox add-source q++# Install the second package+cabal install q
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/p/LICENSE view
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/p/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/p/p.cabal view
@@ -0,0 +1,11 @@+name:                p+version:             0.1.0.0+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/q/LICENSE view
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/q/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/multiple-source/q/q.cabal view
@@ -0,0 +1,11 @@+name:                q+version:             0.1.0.0+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err view
@@ -0,0 +1,3 @@+Warning: Sources not registered: "q"++RE:^cabal(\.exe)?: The sources with the above errors were skipped\. \("q"\)$
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh view
@@ -0,0 +1,10 @@+. ./common.sh++# Create the sandbox+cabal sandbox init > /dev/null++# Add one source+cabal sandbox add-source p > /dev/null++# Remove a source that exists on disk, but is not registered+! cabal sandbox delete-source q
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/LICENSE view
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/p.cabal view
@@ -0,0 +1,11 @@+name:                p+version:             0.1.0.0+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/LICENSE view
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/q.cabal view
@@ -0,0 +1,11 @@+name:                q+version:             0.1.0.0+license-file:        LICENSE+author:              Edward Z. Yang+maintainer:          ezyang@cs.stanford.edu+build-type:          Simple+cabal-version:       >=1.10++library+  build-depends:       base+  default-language:    Haskell2010
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh view
@@ -0,0 +1,22 @@+. ./common.sh++# Create the sandbox+cabal sandbox init++# Add the sources+cabal sandbox add-source p+cabal sandbox add-source q++# delete the directory on disk+rm -R p++# Remove the registered source which is no longer on disk. cabal's handling of+# non-existent sources depends on the behavior of the directory package.+if OUTPUT=`cabal sandbox delete-source p 2>&1`; then+    # 'canonicalizePath' should always succeed with directory >= 1.2.3.0+    echo $OUTPUT | grep 'Success deleting sources: "p"' \+	|| die "Incorrect success message: $OUTPUT"+else+    echo $OUTPUT | grep 'Warning: Source directory not found for paths: "p"' \+	|| die "Incorrect failure message: $OUTPUT"+fi
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.out view
@@ -0,0 +1,6 @@+Success deleting sources: "p" "q"++Note: 'sandbox delete-source' only unregisters the source dependency, but does+not remove the package from the sandbox package DB.++Use 'sandbox hc-pkg -- unregister' to do that.
+ cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh view
@@ -0,0 +1,11 @@+. ./common.sh++# Create the sandbox+cabal sandbox init > /dev/null++# Add the sources+cabal sandbox add-source p > /dev/null+cabal sandbox add-source q > /dev/null++# Remove one of the sources+cabal sandbox delete-source p q
+ cabal/cabal-install/tests/IntegrationTests/user-config/cabal-config view
@@ -0,0 +1,182 @@+-- This is the configuration file for the 'cabal' command line tool.++-- The available configuration options are listed below.+-- Some of them have default values listed.++-- Lines (like this one) beginning with '--' are comments.+-- Be careful with spaces and indentation because they are+-- used to indicate layout for nested sections.+++repository hackage.haskell.org+  url: http://hackage.haskell.org/++-- default-user-config:+-- require-sandbox: False+-- ignore-sandbox: False+-- ignore-expiry: False+-- http-transport:+remote-repo-cache: /home/gman/.cabal/packages+-- local-repo:+-- logs-dir:+world-file: /home/gman/.cabal/world+-- verbose: 1+-- compiler: ghc+-- with-compiler:+-- with-hc-pkg:+-- program-prefix:+-- program-suffix:+-- library-vanilla: True+-- library-profiling:+-- shared:+-- executable-dynamic: False+-- profiling:+-- executable-profiling:+-- profiling-detail:+-- library-profiling-detail:+-- optimization: True+-- debug-info: False+-- library-for-ghci:+-- split-objs: False+-- executable-stripping: True+-- library-stripping: True+-- configure-option:+-- user-install: True+-- package-db:+-- flags:+-- extra-include-dirs:+-- extra-lib-dirs:+extra-prog-path: /home/gman/.cabal/bin+-- tests: False+-- coverage: False+-- library-coverage:+-- exact-configuration: False+-- benchmarks: False+-- relocatable: False+-- cabal-lib-version:+-- constraint:+-- preference:+-- solver: choose+-- allow-newer: False+-- documentation: False+-- doc-index-file: $datadir/doc/$arch-$os-$compiler/index.html+-- max-backjumps: 2000+-- reorder-goals: False+-- shadow-installed-packages: False+-- strong-flags: False+-- reinstall: False+-- avoid-reinstalls: False+-- force-reinstalls: False+-- upgrade-dependencies: False+-- root-cmd:+-- symlink-bindir:+build-summary: /home/gman/.cabal/logs/build.log+-- build-log:+remote-build-reporting: anonymous+-- report-planning-failure: False+-- one-shot: False+-- run-tests:+jobs: $ncpus+-- offline: False+-- username:+-- password:+-- password-command:+-- builddir:++haddock+  -- keep-temp-files: False+  -- hoogle: False+  -- html: False+  -- html-location:+  -- for-hackage: False+  -- executables: False+  -- tests: False+  -- benchmarks: False+  -- all:+  -- internal: False+  -- css:+  -- hyperlink-source: False+  -- hscolour-css:+  -- contents-location:++install-dirs user+  -- prefix: /home/gman/.cabal+  -- bindir: $prefix/bin+  -- libdir: $prefix/lib+  -- libsubdir: $abi/$libname+  -- libexecdir: $prefix/libexec+  -- datadir: $prefix/share+  -- datasubdir: $abi/$pkgid+  -- docdir: $datadir/doc/$abi/$pkgid+  -- htmldir: $docdir/html+  -- haddockdir: $htmldir+  -- sysconfdir: $prefix/etc++install-dirs global+  -- prefix: /usr/local+  -- bindir: $prefix/bin+  -- libdir: $prefix/lib+  -- libsubdir: $abi/$libname+  -- libexecdir: $prefix/libexec+  -- datadir: $prefix/share+  -- datasubdir: $abi/$pkgid+  -- docdir: $datadir/doc/$abi/$pkgid+  -- htmldir: $docdir/html+  -- haddockdir: $htmldir+  -- sysconfdir: $prefix/etc++program-locations+  -- alex-location:+  -- ar-location:+  -- c2hs-location:+  -- cpphs-location:+  -- gcc-location:+  -- ghc-location:+  -- ghc-pkg-location:+  -- ghcjs-location:+  -- ghcjs-pkg-location:+  -- greencard-location:+  -- haddock-location:+  -- happy-location:+  -- haskell-suite-location:+  -- haskell-suite-pkg-location:+  -- hmake-location:+  -- hpc-location:+  -- hsc2hs-location:+  -- hscolour-location:+  -- jhc-location:+  -- ld-location:+  -- lhc-location:+  -- lhc-pkg-location:+  -- pkg-config-location:+  -- strip-location:+  -- tar-location:+  -- uhc-location:++program-default-options+  -- alex-options:+  -- ar-options:+  -- c2hs-options:+  -- cpphs-options:+  -- gcc-options:+  -- ghc-options:+  -- ghc-pkg-options:+  -- ghcjs-options:+  -- ghcjs-pkg-options:+  -- greencard-options:+  -- haddock-options:+  -- happy-options:+  -- haskell-suite-options:+  -- haskell-suite-pkg-options:+  -- hmake-options:+  -- hpc-options:+  -- hsc2hs-options:+  -- hscolour-options:+  -- jhc-options:+  -- ld-options:+  -- lhc-options:+  -- lhc-pkg-options:+  -- pkg-config-options:+  -- strip-options:+  -- tar-options:+  -- uhc-options:
+ cabal/cabal-install/tests/IntegrationTests/user-config/common.sh view
@@ -0,0 +1,9 @@+# Helper to run Cabal+cabal() {+    "$CABAL" $CABAL_ARGS_NO_CONFIG_FILE "$@"+}++die() {+    echo "die: $@"+    exit 1+}
+ cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err view
@@ -0,0 +1,1 @@+RE:^cabal(\.exe)?: \./cabal-config already exists\.$
+ cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh view
@@ -0,0 +1,5 @@+. ./common.sh++rm -f ./cabal-config+cabal --config-file=./cabal-config user-config init > /dev/null+! cabal --config-file=./cabal-config user-config init
+ cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.out view
@@ -0,0 +1,2 @@+Writing default configuration to ./cabal-config+Writing default configuration to ./cabal-config
+ cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.sh view
@@ -0,0 +1,9 @@+. ./common.sh++rm -f ./cabal-config+cabal --config-file=./cabal-config user-config init \+    || die "Couldn't create config file"+cabal --config-file=./cabal-config user-config -f init \+    || die "Couldn't create config file"+test -e ./cabal-config || die "Config file doesn't exist"+rm -f ./cabal-config
+ cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.out view
@@ -0,0 +1,1 @@+Writing default configuration to ./cabal-config
+ cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.sh view
@@ -0,0 +1,7 @@+. ./common.sh++rm -f ./cabal-config+cabal --config-file=./cabal-config user-config init \+    || die "Couldn't create config file"+test -e ./cabal-config || die "Config file doesn't exist"+rm -f ./cabal-config
+ cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out view
@@ -0,0 +1,1 @@+Writing default configuration to ./my-config
+ cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh view
@@ -0,0 +1,5 @@+. ./common.sh++export CABAL_CONFIG=./my-config+cabal user-config init || die "Couldn't create config file"+test -e ./my-config || die "Config file doesn't exist"
− cabal/cabal-install/tests/PackageTests.hs 
@@ -1,95 +0,0 @@--- | Groups black-box tests of cabal-install and configures them to test--- the correct binary.------ This file should do nothing but import tests from other modules and run--- them with the path to the correct cabal-install binary.-module Main-       where---- Modules from Cabal.-import Distribution.Simple.Configure (findDistPrefOrDefault)-import Distribution.Simple.Program.Builtin (ghcPkgProgram)-import Distribution.Simple.Program.Db-        (defaultProgramDb, requireProgram, setProgramSearchPath)-import Distribution.Simple.Program.Find-        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)-import Distribution.Simple.Program.Types-        ( Program(..), simpleProgram, programPath)-import Distribution.Simple.Setup ( Flag(..) )-import Distribution.Simple.Utils ( findProgramVersion )-import Distribution.Verbosity (normal)---- Third party modules.-import qualified Control.Exception.Extensible as E-import Distribution.Compat.Environment ( setEnv )-import System.Directory-        ( canonicalizePath, getCurrentDirectory, setCurrentDirectory-        , removeFile, doesFileExist )-import System.FilePath ((</>))-import Test.Tasty (TestTree, defaultMain, testGroup)-import Control.Monad ( when )---- Module containing common test code.--import PackageTests.PackageTester ( TestsPaths(..)-                                  , packageTestsDirectory-                                  , packageTestsConfigFile )---- Modules containing the tests.-import qualified PackageTests.Exec.Check-import qualified PackageTests.Freeze.Check-import qualified PackageTests.MultipleSource.Check---- List of tests to run. Each test will be called with the path to the--- cabal binary to use.-tests :: PackageTests.PackageTester.TestsPaths -> TestTree-tests paths = testGroup "Package Tests" $-    [ testGroup "Freeze"         $ PackageTests.Freeze.Check.tests         paths-    , testGroup "Exec"           $ PackageTests.Exec.Check.tests           paths-    , testGroup "MultipleSource" $ PackageTests.MultipleSource.Check.tests paths-    ]--cabalProgram :: Program-cabalProgram = (simpleProgram "cabal") {-    programFindVersion = findProgramVersion "--numeric-version" id-  }--main :: IO ()-main = do-    -- Find the builddir used to build Cabal-    distPref <- findDistPrefOrDefault NoFlag-    -- Use the default builddir for all of the subsequent package tests-    setEnv "CABAL_BUILDDIR" "dist"-    buildDir <- canonicalizePath (distPref </> "build/cabal")-    let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath-    (cabal, _) <- requireProgram normal cabalProgram-                      (setProgramSearchPath programSearchPath defaultProgramDb)-    (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb-    canonicalConfigPath <- canonicalizePath $ "tests" </> packageTestsDirectory--    let testsPaths = TestsPaths {-          cabalPath = programPath cabal,-          ghcPkgPath = programPath ghcPkg,-          configPath = canonicalConfigPath </> packageTestsConfigFile-        }--    putStrLn $ "Using cabal: "   ++ cabalPath  testsPaths-    putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath testsPaths--    cwd <- getCurrentDirectory-    let confFile = packageTestsDirectory </> "cabal-config"-        removeConf = do-          b <- doesFileExist confFile-          when b $ removeFile confFile-    let runTests = do-          setCurrentDirectory "tests"-          removeConf -- assert that there is no existing config file-                     -- (we want deterministic testing with the default-                     --  config values)-          defaultMain $ tests testsPaths-    runTests `E.finally` do-        -- remove the default config file that got created by the tests-        removeConf-        -- Change back to the old working directory so that the tests can be-        -- repeatedly run in `cabal repl` via `:main`.-        setCurrentDirectory cwd
− cabal/cabal-install/tests/PackageTests/Exec/Check.hs 
@@ -1,145 +0,0 @@-{-# LANGUAGE CPP #-}-module PackageTests.Exec.Check-       ( tests-       ) where---import PackageTests.PackageTester--import Test.Tasty-import Test.Tasty.HUnit--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Monad (when)-import Data.List (intercalate, isInfixOf)-import System.FilePath ((</>))-import System.Directory (getDirectoryContents)--dir :: FilePath-dir = packageTestsDirectory </> "Exec"--tests :: TestsPaths -> [TestTree]-tests paths =-    [ testCase "exits with failure if given no argument" $ do-          result <- cabal_exec paths dir []-          assertExecFailed result--    , testCase "prints error message if given no argument" $ do-          result <- cabal_exec paths dir []-          assertExecFailed result-          let output = outputText result-              expected = "specify an executable to run"-              errMsg = "should have requested an executable be specified\n" ++-                       output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "runs the given command" $ do-          result <- cabal_exec paths dir ["echo", "this", "string"]-          assertExecSucceeded result-          let output = outputText result-              expected = "this string"-              errMsg = "should have ran the given command\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "can run executables installed in the sandbox" $ do-          -- Test that an executable installed into the sandbox can be found.-          -- We do this by removing any existing sandbox. Checking that the-          -- executable cannot be found. Creating a new sandbox. Installing-          -- the executable and checking it can be run.--          cleanPreviousBuilds paths-          assertMyExecutableNotFound paths-          assertPackageInstall paths--          result <- cabal_exec paths dir ["my-executable"]-          assertExecSucceeded result-          let output = outputText result-              expected = "This is my-executable"-              errMsg = "should have found a my-executable\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "adds the sandbox bin directory to the PATH" $ do-          cleanPreviousBuilds paths-          assertMyExecutableNotFound paths-          assertPackageInstall paths--          result <- cabal_exec paths dir ["bash", "--", "-c", "my-executable"]-          assertExecSucceeded result-          let output = outputText result-              expected = "This is my-executable"-              errMsg = "should have found a my-executable\n" ++ output-          assertBool errMsg $-              expected `isInfixOf` (intercalate " " . lines $ output)--    , testCase "configures GHC to use the sandbox" $ do-          let libNameAndVersion = "my-0.1"--          cleanPreviousBuilds paths-          assertPackageInstall paths--          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion--          result <- cabal_exec paths dir ["ghc-pkg", "list"]-          assertExecSucceeded result-          let output = outputText result-              errMsg = "my library should have been found"-          assertBool errMsg $-              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)-          --    -- , testCase "can find executables built from the package" $ do--    , testCase "configures cabal to use the sandbox" $ do-          let libNameAndVersion = "my-0.1"--          cleanPreviousBuilds paths-          assertPackageInstall paths--          assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion--          result <- cabal_exec paths dir ["bash", "--", "-c", "cd subdir ; cabal sandbox hc-pkg list"]-          assertExecSucceeded result-          let output = outputText result-              errMsg = "my library should have been found"-          assertBool errMsg $-              libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)-    ]--cleanPreviousBuilds :: TestsPaths -> IO ()-cleanPreviousBuilds paths = do-    sandboxExists <- not . null . filter (== "cabal.sandbox.config") <$>-                         getDirectoryContents dir-    assertCleanSucceeded   =<< cabal_clean paths dir []-    when sandboxExists $ do-        assertSandboxSucceeded =<< cabal_sandbox paths dir ["delete"]---assertPackageInstall :: TestsPaths -> IO ()-assertPackageInstall paths = do-    assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]-    assertInstallSucceeded =<< cabal_install paths dir []---assertMyExecutableNotFound :: TestsPaths -> IO ()-assertMyExecutableNotFound paths = do-    result <- cabal_exec paths dir ["my-executable"]-    assertExecFailed result-    let output = outputText result-        expected = "The program 'my-executable' is required but it " ++-                   "could not be found"-        errMsg = "should not have found a my-executable\n" ++ output-    assertBool errMsg $-        expected `isInfixOf` (intercalate " " . lines $ output)----assertMyLibIsNotAvailableOutsideofSandbox :: TestsPaths -> String -> IO ()-assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion = do-    (_, _, output) <- run (Just $ dir) (ghcPkgPath paths) ["list"]-    assertBool "my library should not have been found" $ not $-        libNameAndVersion `isInfixOf` (intercalate " " . lines $ output)
− cabal/cabal-install/tests/PackageTests/Exec/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--foo :: String-foo = "foo"
− cabal/cabal-install/tests/PackageTests/Exec/My.hs 
@@ -1,5 +0,0 @@-module Main where--main :: IO ()-main = do-    putStrLn "This is my-executable"
− cabal/cabal-install/tests/PackageTests/Exec/my.cabal 
@@ -1,14 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.2-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base---executable my-executable-    main-is:            My.hs-    build-depends:      base
− cabal/cabal-install/tests/PackageTests/Exec/subdir/.gitkeep 
− cabal/cabal-install/tests/PackageTests/Freeze/Check.hs 
@@ -1,116 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module PackageTests.Freeze.Check-       ( tests-       ) where--import PackageTests.PackageTester--import Test.Tasty-import Test.Tasty.HUnit--import qualified Control.Exception.Extensible as E-import Data.List (intercalate, isInfixOf)-import System.Directory (doesFileExist, removeFile)-import System.FilePath ((</>))-import System.IO.Error (isDoesNotExistError)--dir :: FilePath-dir = packageTestsDirectory </> "Freeze"--tests :: TestsPaths -> [TestTree]-tests paths =-    [ testCase "runs without error" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result--    , testCase "freezes direct dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen base\n" ++ c) $-              " base ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "freezes transitory dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen ghc-prim\n" ++ c) $-              " ghc-prim ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "does not freeze packages which are not dependend upon" $ do-          -- TODO: Test this against a package installed in the sandbox but-          -- not depended upon.-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen exceptions\n" ++ c) $ not $-              " exceptions ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "does not include a constraint for the package being frozen" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir []-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen self\n" ++ c) $ not $-              " my ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--dry-run does not modify the cabal.config file" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--dry-run"]-          assertFreezeSucceeded result-          c <- doesFileExist $ dir </> "cabal.config"-          assertBool "cabal.config file should not have been created" (not c)--    , testCase "--enable-tests freezes test dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--enable-tests"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should have frozen test-framework\n" ++ c) $-              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--disable-tests does not freeze test dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-tests"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen test-framework\n" ++ c) $ not $-              " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--enable-benchmarks freezes benchmark dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-benchmarks"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen criterion\n" ++ c) $ not $-              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)--    , testCase "--disable-benchmarks does not freeze benchmark dependencies" $ do-          removeCabalConfig-          result <- cabal_freeze paths dir ["--disable-benchmarks"]-          assertFreezeSucceeded result-          c <- readCabalConfig-          assertBool ("should not have frozen criterion\n" ++ c) $ not $-              " criterion ==" `isInfixOf` (intercalate " " $ lines $ c)-    ]--removeCabalConfig :: IO ()-removeCabalConfig = do-    removeFile (dir </> "cabal.config")-    `E.catch` \ (e :: IOError) ->-        if isDoesNotExistError e-        then return ()-        else E.throw e---readCabalConfig :: IO String-readCabalConfig = do-    config <- readFile $ dir </> "cabal.config"-    -- Ensure that the file is closed so that it can be-    -- deleted by the next test on Windows.-    length config `seq` return config
− cabal/cabal-install/tests/PackageTests/Freeze/my.cabal 
@@ -1,21 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.20.0-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base--test-suite test-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: tests-    main-is:    test-Foo.hs-    build-depends: base, my, test-framework--benchmark bench-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: benchmarks-    main-is:    benchmark-Foo.hs-    build-depends: base, my, criterion
− cabal/cabal-install/tests/PackageTests/MultipleSource/Check.hs 
@@ -1,28 +0,0 @@-module PackageTests.MultipleSource.Check-       ( tests-       ) where---import PackageTests.PackageTester--import Test.Tasty-import Test.Tasty.HUnit--import Control.Monad    (void, when)-import System.Directory (doesDirectoryExist)-import System.FilePath  ((</>))--dir :: FilePath-dir = packageTestsDirectory </> "MultipleSource"--tests :: TestsPaths -> [TestTree]-tests paths =-    [ testCase "finds second source of multiple source" $ do-          sandboxExists <- doesDirectoryExist $ dir </> ".cabal-sandbox"-          when sandboxExists $-            void $ cabal_sandbox paths dir ["delete"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "p"]-          assertSandboxSucceeded =<< cabal_sandbox paths dir ["add-source", "q"]-          assertInstallSucceeded =<< cabal_install paths dir ["q"]-    ]
− cabal/cabal-install/tests/PackageTests/MultipleSource/p/LICENSE 
− cabal/cabal-install/tests/PackageTests/MultipleSource/p/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− cabal/cabal-install/tests/PackageTests/MultipleSource/p/p.cabal 
@@ -1,11 +0,0 @@-name:                p-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− cabal/cabal-install/tests/PackageTests/MultipleSource/q/LICENSE 
− cabal/cabal-install/tests/PackageTests/MultipleSource/q/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− cabal/cabal-install/tests/PackageTests/MultipleSource/q/q.cabal 
@@ -1,11 +0,0 @@-name:                q-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.10--library-  build-depends:       base-  default-language:    Haskell2010
− cabal/cabal-install/tests/PackageTests/PackageTester.hs 
@@ -1,232 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- TODO This module was originally based on the PackageTests.PackageTester--- module in Cabal, however it has a few differences. I suspect that as--- this module ages the two modules will diverge further. As such, I have--- not attempted to merge them into a single module nor to extract a common--- module from them.  Refactor this module and/or Cabal's--- PackageTests.PackageTester to remove commonality.---   2014-05-15 Ben Armston---- | Routines for black-box testing cabal-install.------ Instead of driving the tests by making library calls into--- Distribution.Simple.* or Distribution.Client.* this module only every--- executes the `cabal-install` binary.------ You can set the following VERBOSE environment variable to control--- the verbosity of the output generated by this module.-module PackageTests.PackageTester-    ( TestsPaths(..)-    , Result(..)--    , packageTestsDirectory-    , packageTestsConfigFile--    -- * Running cabal commands-    , cabal_clean-    , cabal_exec-    , cabal_freeze-    , cabal_install-    , cabal_sandbox-    , run--    -- * Test helpers-    , assertCleanSucceeded-    , assertExecFailed-    , assertExecSucceeded-    , assertFreezeSucceeded-    , assertInstallSucceeded-    , assertSandboxSucceeded-    ) where--import qualified Control.Exception.Extensible as E-import Control.Monad (when, unless)-import Data.Maybe (fromMaybe)-import System.Directory (canonicalizePath, doesFileExist)-import System.Environment (getEnv)-import System.Exit (ExitCode(ExitSuccess))-import System.FilePath ( (<.>)  )-import System.IO (hClose, hGetChar, hIsEOF)-import System.IO.Error (isDoesNotExistError)-import System.Process (runProcess, waitForProcess)-import Test.Tasty.HUnit (Assertion, assertFailure)--import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.Simple.Utils (printRawCommandAndArgs)-import Distribution.Compat.CreatePipe (createPipe)-import Distribution.ReadE (readEOrFail)-import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)--data Success = Failure-             -- | ConfigureSuccess-             -- | BuildSuccess-             -- | TestSuccess-             -- | BenchSuccess-             | CleanSuccess-             | ExecSuccess-             | FreezeSuccess-             | InstallSuccess-             | SandboxSuccess-             deriving (Eq, Show)--data TestsPaths = TestsPaths-    { cabalPath  :: FilePath -- ^ absolute path to cabal executable.-    , ghcPkgPath :: FilePath -- ^ absolute path to ghc-pkg executable.-    , configPath :: FilePath -- ^ absolute path of the default config file-                             --   to use for tests (tests are free to use-                             --   a different one).-    }--data Result = Result-    { successful :: Bool-    , success    :: Success-    , outputText :: String-    } deriving Show--nullResult :: Result-nullResult = Result True Failure ""----------------------------------------------------------------------------- * Config--packageTestsDirectory :: FilePath-packageTestsDirectory = "PackageTests"--packageTestsConfigFile :: FilePath-packageTestsConfigFile = "cabal-config"----------------------------------------------------------------------------- * Running cabal commands--recordRun :: (String, ExitCode, String) -> Success -> Result -> Result-recordRun (cmd, exitCode, exeOutput) thisSucc res =-    res { successful = successful res && exitCode == ExitSuccess-        , success    = if exitCode == ExitSuccess then thisSucc-                       else success res-        , outputText =-            (if null $ outputText res then "" else outputText res ++ "\n") ++-            cmd ++ "\n" ++ exeOutput-        }---- | Run the clean command and return its result.-cabal_clean :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_clean paths dir args = do-    res <- cabal paths dir (["clean"] ++ args)-    return $ recordRun res CleanSuccess nullResult---- | Run the exec command and return its result.-cabal_exec :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_exec paths dir args = do-    res <- cabal paths dir (["exec"] ++ args)-    return $ recordRun res ExecSuccess nullResult---- | Run the freeze command and return its result.-cabal_freeze :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_freeze paths dir args = do-    res <- cabal paths dir (["freeze"] ++ args)-    return $ recordRun res FreezeSuccess nullResult---- | Run the install command and return its result.-cabal_install :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_install paths dir args = do-    res <- cabal paths dir (["install"] ++ args)-    return $ recordRun res InstallSuccess nullResult---- | Run the sandbox command and return its result.-cabal_sandbox :: TestsPaths -> FilePath -> [String] -> IO Result-cabal_sandbox paths dir args = do-    res <- cabal paths dir (["sandbox"] ++ args)-    return $ recordRun res SandboxSuccess nullResult---- | Returns the command that was issued, the return code, and the output text.-cabal :: TestsPaths -> FilePath -> [String] -> IO (String, ExitCode, String)-cabal paths dir cabalArgs = do-    run (Just dir) (cabalPath paths) args-  where-    args = configFileArg : cabalArgs-    configFileArg = "--config-file=" ++ configPath paths---- | Returns the command that was issued, the return code, and the output text-run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)-run cwd path args = do-    verbosity <- getVerbosity-    -- path is relative to the current directory; canonicalizePath makes it-    -- absolute, so that runProcess will find it even when changing directory.-    path' <- do pathExists <- doesFileExist path-                canonicalizePath (if pathExists then path else path <.> exeExtension)-    printRawCommandAndArgs verbosity path' args-    (readh, writeh) <- createPipe-    pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)--    -- fork off a thread to start consuming the output-    out <- suckH [] readh-    hClose readh--    -- wait for the program to terminate-    exitcode <- waitForProcess pid-    let fullCmd = unwords (path' : args)-    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)-  where-    suckH output h = do-        eof <- hIsEOF h-        if eof-            then return (reverse output)-            else do-                c <- hGetChar h-                suckH (c:output) h----------------------------------------------------------------------------- * Test helpers--assertCleanSucceeded :: Result -> Assertion-assertCleanSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal clean\' should succeed\n" ++-    "  output: " ++ outputText result--assertExecSucceeded :: Result -> Assertion-assertExecSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal exec\' should succeed\n" ++-    "  output: " ++ outputText result--assertExecFailed :: Result -> Assertion-assertExecFailed result = when (successful result) $-    assertFailure $-    "expected: \'cabal exec\' should fail\n" ++-    "  output: " ++ outputText result--assertFreezeSucceeded :: Result -> Assertion-assertFreezeSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal freeze\' should succeed\n" ++-    "  output: " ++ outputText result--assertInstallSucceeded :: Result -> Assertion-assertInstallSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal install\' should succeed\n" ++-    "  output: " ++ outputText result--assertSandboxSucceeded :: Result -> Assertion-assertSandboxSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'cabal sandbox\' should succeed\n" ++-    "  output: " ++ outputText result----------------------------------------------------------------------------- Verbosity--lookupEnv :: String -> IO (Maybe String)-lookupEnv name =-    (fmap Just $ getEnv name)-    `E.catch` \ (e :: IOError) ->-        if isDoesNotExistError e-        then return Nothing-        else E.throw e---- TODO: Convert to a "-v" flag instead.-getVerbosity :: IO Verbosity-getVerbosity = do-    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"
− cabal/cabal-install/tests/README 
@@ -1,1 +0,0 @@-See Cabal/tests/README.
+ cabal/cabal-install/tests/README.md view
@@ -0,0 +1,27 @@+Integration Tests+=================++Each test is a shell script.  Tests that share files (e.g., `.cabal` files) are+grouped under a common sub-directory of [IntegrationTests].  The framework+copies the whole group's directory before running each test, which allows tests+to reuse files, yet run independently.  A group's tests are further divided into+`should_run` and `should_fail` directories, based on the expected exit status.+For example, the test+`IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh` has access+to all files under `exec` and is expected to fail.++Tests can specify their expected output.  For a test named `x.sh`, `x.out`+specifies `stdout` and `x.err` specifies `stderr`.  Both files are optional.+The framework expects an exact match between lines in the file and output,+except for lines beginning with "RE:", which are interpreted as regular+expressions.++[IntegrationTests.hs] defines several environment variables:++* `CABAL` - The path to the executable being tested.+* `GHC_PKG` - The path to ghc-pkg.+* `CABAL_ARGS` - A common set of arguments for running cabal.+* `CABAL_ARGS_NO_CONFIG_FILE` - `CABAL_ARGS` without `--config-file`.++[IntegrationTests]: IntegrationTests+[IntegrationTests.hs]: IntegrationTests.hs
+ cabal/cabal-install/tests/SolverQuickCheck.hs view
@@ -0,0 +1,16 @@+module Main where++import Test.Tasty++import qualified UnitTests.Distribution.Client.Dependency.Modular.QuickCheck+++tests :: TestTree+tests =+  testGroup "Solver QuickCheck"+  [ testGroup "UnitTests.Distribution.Client.Dependency.Modular.QuickCheck"+        UnitTests.Distribution.Client.Dependency.Modular.QuickCheck.tests+  ]++main :: IO ()+main = defaultMain tests
cabal/cabal-install/tests/UnitTests.hs view
@@ -1,39 +1,106 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Main        where  import Test.Tasty-import Test.Tasty.Options -import qualified UnitTests.Distribution.Client.Sandbox-import qualified UnitTests.Distribution.Client.UserConfig-import qualified UnitTests.Distribution.Client.Targets-import qualified UnitTests.Distribution.Client.GZipUtils+import Control.Monad+import Data.Time.Clock+import System.FilePath++import Distribution.Simple.Utils+import Distribution.Verbosity++import Distribution.Client.Compat.Time++import qualified UnitTests.Distribution.Client.Compat.Time import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver+import qualified UnitTests.Distribution.Client.FileMonitor+import qualified UnitTests.Distribution.Client.Glob+import qualified UnitTests.Distribution.Client.GZipUtils+import qualified UnitTests.Distribution.Client.Sandbox+import qualified UnitTests.Distribution.Client.Sandbox.Timestamp+import qualified UnitTests.Distribution.Client.Tar+import qualified UnitTests.Distribution.Client.Targets+import qualified UnitTests.Distribution.Client.UserConfig+import qualified UnitTests.Distribution.Client.ProjectConfig -tests :: TestTree-tests = testGroup "Unit Tests" [-   testGroup "UnitTests.Distribution.Client.UserConfig"-       UnitTests.Distribution.Client.UserConfig.tests-  ,testGroup "Distribution.Client.Sandbox"-       UnitTests.Distribution.Client.Sandbox.tests-  ,testGroup "Distribution.Client.Targets"-       UnitTests.Distribution.Client.Targets.tests-  ,testGroup "Distribution.Client.GZipUtils"-       UnitTests.Distribution.Client.GZipUtils.tests-  ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"+import UnitTests.Options+++tests :: Int -> TestTree+tests mtimeChangeCalibrated =+  askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->+  let mtimeChange = if mtimeChangeProvided /= 0+                    then mtimeChangeProvided+                    else mtimeChangeCalibrated+  in+  testGroup "Unit Tests"+  [ testGroup "UnitTests.Distribution.Client.Compat.Time" $+        UnitTests.Distribution.Client.Compat.Time.tests mtimeChange+  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"         UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests-  ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"+  , testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"         UnitTests.Distribution.Client.Dependency.Modular.Solver.tests-  ]---- Extra options for running the test suite-extraOptions :: [OptionDescription]-extraOptions = concat [-    UnitTests.Distribution.Client.Dependency.Modular.Solver.options+  , testGroup "UnitTests.Distribution.Client.FileMonitor" $+        UnitTests.Distribution.Client.FileMonitor.tests mtimeChange+  , testGroup "UnitTests.Distribution.Client.Glob"+        UnitTests.Distribution.Client.Glob.tests+  , testGroup "Distribution.Client.GZipUtils"+       UnitTests.Distribution.Client.GZipUtils.tests+  , testGroup "Distribution.Client.Sandbox"+       UnitTests.Distribution.Client.Sandbox.tests+  , testGroup "Distribution.Client.Sandbox.Timestamp"+       UnitTests.Distribution.Client.Sandbox.Timestamp.tests+  , testGroup "Distribution.Client.Tar"+       UnitTests.Distribution.Client.Tar.tests+  , testGroup "Distribution.Client.Targets"+       UnitTests.Distribution.Client.Targets.tests+  , testGroup "UnitTests.Distribution.Client.UserConfig"+       UnitTests.Distribution.Client.UserConfig.tests+  , testGroup "UnitTests.Distribution.Client.ProjectConfig"+       UnitTests.Distribution.Client.ProjectConfig.tests   ]  main :: IO ()-main = defaultMainWithIngredients+main = do+  mtimeChangeDelay <- calibrateMtimeChangeDelay+  defaultMainWithIngredients          (includingOptions extraOptions : defaultIngredients)-         tests+         (tests mtimeChangeDelay)++-- Based on code written by Neill Mitchell for Shake. See+-- 'sleepFileTimeCalibrate' in 'Test.Type'. The returned delay is never smaller+-- than 10 ms, but never larger than 1 second.+calibrateMtimeChangeDelay :: IO Int+calibrateMtimeChangeDelay = do+  withTempDirectory silent "." "calibration-" $ \dir -> do+    let fileName = dir </> "probe"+    mtimes <- forM [1..25] $ \(i::Int) -> time $ do+      writeFile fileName $ show i+      t0 <- getModTime fileName+      let spin j = do+            writeFile fileName $ show (i,j)+            t1 <- getModTime fileName+            unless (t0 < t1) (spin $ j + 1)+      spin (0::Int)+    let mtimeChange  = maximum mtimes+        mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2+    notice normal $ "File modification time resolution calibration completed, "+      ++ "maximum delay observed: "+      ++ (show . toMillis $ mtimeChange ) ++ " ms. "+      ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')+      ++ " for test runs."+    return mtimeChange'+  where+    toMillis :: Int -> Double+    toMillis x = fromIntegral x / 1000.0++    time :: IO () -> IO Int+    time act = do+      t0 <- getCurrentTime+      act+      t1 <- getCurrentTime+      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.ArbitraryInstances (+    adjustSize,+    shortListOf,+    shortListOf1,+    arbitraryFlag,+    ShortToken(..),+    arbitraryShortToken,+    NonMEmpty(..),+    NoShrink(..),+  ) where++import Data.Char+import Data.List+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Control.Applicative+#endif+import Control.Monad++import Distribution.Version+import Distribution.Package+import Distribution.System+import Distribution.Verbosity++import Distribution.Simple.Setup+import Distribution.Simple.InstallDirs++import Distribution.Utils.NubList++import Test.QuickCheck+++adjustSize :: (Int -> Int) -> Gen a -> Gen a+adjustSize adjust gen = sized (\n -> resize (adjust n) gen)++shortListOf :: Int -> Gen a -> Gen [a]+shortListOf bound gen =+    sized $ \n -> do+      k <- choose (0, (n `div` 2) `min` bound)+      vectorOf k gen++shortListOf1 :: Int -> Gen a -> Gen [a]+shortListOf1 bound gen =+    sized $ \n -> do+      k <- choose (1, 1 `max` ((n `div` 2) `min` bound))+      vectorOf k gen++newtype ShortToken = ShortToken { getShortToken :: String }+  deriving Show++instance Arbitrary ShortToken where+  arbitrary =+    ShortToken <$>+      (shortListOf1 5 (choose ('#', '~'))+       `suchThat` (not . ("[]" `isPrefixOf`)))+    --TODO: [code cleanup] need to replace parseHaskellString impl to stop+    -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.+    -- Workaround, don't generate [] as this does not round trip.+++  shrink (ShortToken cs) =+    [ ShortToken cs' | cs' <- shrink cs, not (null cs') ]++arbitraryShortToken :: Gen String+arbitraryShortToken = getShortToken <$> arbitrary++instance Arbitrary Version where+  arbitrary = do+    branch <- shortListOf1 4 $+                frequency [(3, return 0)+                          ,(3, return 1)+                          ,(2, return 2)+                          ,(1, return 3)]+    return (Version branch []) -- deliberate []+    where++  shrink (Version branch []) =+    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]+  shrink (Version branch _tags) =+    [ Version branch [] ]++instance Arbitrary VersionRange where+  arbitrary = canonicaliseVersionRange <$> sized verRangeExp+    where+      verRangeExp n = frequency $+        [ (2, return anyVersion)+        , (1, liftM thisVersion arbitrary)+        , (1, liftM laterVersion arbitrary)+        , (1, liftM orLaterVersion arbitrary)+        , (1, liftM orLaterVersion' arbitrary)+        , (1, liftM earlierVersion arbitrary)+        , (1, liftM orEarlierVersion arbitrary)+        , (1, liftM orEarlierVersion' arbitrary)+        , (1, liftM withinVersion arbitrary)+        , (2, liftM VersionRangeParens arbitrary)+        ] ++ if n == 0 then [] else+        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)+        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)+        ]+        where+          verRangeExp2 = verRangeExp (n `div` 2)++      orLaterVersion'   v =+        unionVersionRanges (laterVersion v)   (thisVersion v)+      orEarlierVersion' v =+        unionVersionRanges (earlierVersion v) (thisVersion v)++      canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals++instance Arbitrary PackageName where+    arbitrary = PackageName . intercalate "-" <$> shortListOf1 2 nameComponent+      where+        nameComponent = shortListOf1 5 (elements packageChars)+                        `suchThat` (not . all isDigit)+        packageChars  = filter isAlphaNum ['\0'..'\127']++instance Arbitrary Dependency where+    arbitrary = Dependency <$> arbitrary <*> arbitrary++instance Arbitrary OS where+    arbitrary = elements knownOSs++instance Arbitrary Arch where+    arbitrary = elements knownArches++instance Arbitrary Platform where+    arbitrary = Platform <$> arbitrary <*> arbitrary++instance Arbitrary a => Arbitrary (Flag a) where+    arbitrary = arbitraryFlag arbitrary+    shrink NoFlag   = []+    shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ]++arbitraryFlag :: Gen a -> Gen (Flag a)+arbitraryFlag genA =+    sized $ \sz ->+      case sz of+        0 -> pure NoFlag+        _ -> frequency [ (1, pure NoFlag)+                       , (3, Flag <$> genA) ]+++instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where+    arbitrary = toNubList <$> arbitrary+    shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ]+    -- try empty, otherwise don't shrink as it can loop++instance Arbitrary Verbosity where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary PathTemplate where+    arbitrary = toPathTemplate <$> arbitraryShortToken+    shrink t  = [ toPathTemplate s | s <- shrink (show t), not (null s) ]+++newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }+  deriving (Eq, Ord, Show)++instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where+  arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))+  shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]++newtype NoShrink a = NoShrink { getNoShrink :: a }+  deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (NoShrink a) where+    arbitrary = NoShrink <$> arbitrary+    shrink _  = []+
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Compat/Time.hs view
@@ -0,0 +1,49 @@+module UnitTests.Distribution.Client.Compat.Time (tests) where++import Control.Concurrent (threadDelay)+import System.FilePath++import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity++import Distribution.Client.Compat.Time++import Test.Tasty+import Test.Tasty.HUnit++tests :: Int -> [TestTree]+tests mtimeChange =+  [ testCase "getModTime has sub-second resolution" $ getModTimeTest mtimeChange+  , testCase "getCurTime works as expected"         $ getCurTimeTest mtimeChange+  ]++getModTimeTest :: Int -> Assertion+getModTimeTest mtimeChange =+  withTempDirectory silent "." "getmodtime-" $ \dir -> do+    let fileName = dir </> "foo"+    writeFile fileName "bar"+    t0 <- getModTime fileName+    threadDelay mtimeChange+    writeFile fileName "baz"+    t1 <- getModTime fileName+    assertBool "expected different file mtimes" (t1 > t0)+++getCurTimeTest :: Int -> Assertion+getCurTimeTest mtimeChange =+  withTempDirectory silent "." "getmodtime-" $ \dir -> do+    let fileName = dir </> "foo"+    writeFile fileName "bar"+    t0 <- getModTime fileName+    threadDelay mtimeChange+    t1 <- getCurTime+    assertBool("expected file mtime (" ++ show t0+               ++ ") to be earlier than current time (" ++ show t1 ++ ")")+      (t0 < t1)++    threadDelay mtimeChange+    writeFile fileName "baz"+    t2 <- getModTime fileName+    assertBool ("expected current time (" ++ show t1+                ++ ") to be earlier than file mtime (" ++ show t2 ++ ")")+      (t1 < t2)
cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs view
@@ -2,17 +2,31 @@ -- | DSL for testing the modular solver module UnitTests.Distribution.Client.Dependency.Modular.DSL (     ExampleDependency(..)+  , Dependencies(..)+  , ExTest(..)+  , ExPreference(..)   , ExampleDb+  , ExampleVersionRange+  , ExamplePkgVersion+  , ExamplePkgName+  , ExampleAvailable(..)+  , ExampleInstalled(..)+  , IndepGoals(..)+  , ReorderGoals(..)   , exAv   , exInst+  , exFlag   , exResolve   , extractInstallPlan   , withSetupDeps+  , withTest+  , withTests   ) where  -- base import Data.Either (partitionEithers) import Data.Maybe (catMaybes)+import Data.List (nub) import Data.Monoid import Data.Version import qualified Data.Map as Map@@ -21,11 +35,12 @@ import qualified Distribution.Compiler             as C import qualified Distribution.InstalledPackageInfo as C import qualified Distribution.Package              as C-  hiding (HasInstalledPackageId(..))+  hiding (HasUnitId(..)) import qualified Distribution.PackageDescription   as C import qualified Distribution.Simple.PackageIndex  as C.PackageIndex import qualified Distribution.System               as C import qualified Distribution.Version              as C+import Language.Haskell.Extension (Extension(..), Language)  -- cabal-install import Distribution.Client.ComponentDeps (ComponentDeps)@@ -34,6 +49,7 @@ import Distribution.Client.Types import qualified Distribution.Client.InstallPlan   as CI.InstallPlan import qualified Distribution.Client.PackageIndex  as CI.PackageIndex+import qualified Distribution.Client.PkgConfigDb   as PC import qualified Distribution.Client.ComponentDeps as CD  {-------------------------------------------------------------------------------@@ -59,7 +75,7 @@   * The difference between `GenericPackageDescription` and `PackageDescription`     is that `PackageDescription` describes a particular _configuration_ of a     package (for instance, see documentation for `checkPackage`). A-    `GenericPackageDescription` can be returned into a `PackageDescription` in+    `GenericPackageDescription` can be turned into a `PackageDescription` in     two ways:        a. `finalizePackageDescription` does the proper translation, by taking@@ -83,7 +99,11 @@ type ExamplePkgHash    = String  -- for example "installed" packages type ExampleFlagName   = String type ExampleTestName   = String+type ExampleVersionRange = C.VersionRange +data Dependencies = NotBuildable | Buildable [ExampleDependency]+  deriving Show+ data ExampleDependency =     -- | Simple dependency on any version     ExAny ExamplePkgName@@ -92,56 +112,110 @@   | ExFix ExamplePkgName ExamplePkgVersion      -- | Dependencies indexed by a flag-  | ExFlag ExampleFlagName [ExampleDependency] [ExampleDependency]+  | ExFlag ExampleFlagName Dependencies Dependencies -    -- | Dependency if tests are enabled-  | ExTest ExampleTestName [ExampleDependency]+    -- | Dependency on a language extension+  | ExExt Extension +    -- | Dependency on a language version+  | ExLang Language++    -- | Dependency on a pkg-config package+  | ExPkg (ExamplePkgName, ExamplePkgVersion)+  deriving Show++data ExTest = ExTest ExampleTestName [ExampleDependency]++exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]+       -> ExampleDependency+exFlag n t e = ExFlag n (Buildable t) (Buildable e)++data ExPreference = ExPref String ExampleVersionRange+ data ExampleAvailable = ExAv {     exAvName    :: ExamplePkgName   , exAvVersion :: ExamplePkgVersion   , exAvDeps    :: ComponentDeps [ExampleDependency]-  }+  } deriving Show +-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',+-- given:+--+--      1. The name 'ExamplePkgName' of the available package,+--      2. The version 'ExamplePkgVersion' available+--      3. The list of dependency constraints 'ExampleDependency'+--         that this package has.  'ExampleDependency' provides+--         a number of pre-canned dependency types to look at.+-- exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]      -> ExampleAvailable exAv n v ds = ExAv { exAvName = n, exAvVersion = v-                   , exAvDeps = CD.fromLibraryDeps ds }+                   , exAvDeps = CD.fromLibraryDeps n ds }  withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable withSetupDeps ex setupDeps = ex {       exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps     } +withTest :: ExampleAvailable -> ExTest -> ExampleAvailable+withTest ex test = withTests ex [test]++withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable+withTests ex tests =+  let testCDs = CD.fromList [(CD.ComponentTest name, deps)+                            | ExTest name deps <- tests]+  in ex { exAvDeps = exAvDeps ex <> testCDs }++-- | An installed package in 'ExampleDb'; construct me with 'exInst'. data ExampleInstalled = ExInst {     exInstName         :: ExamplePkgName   , exInstVersion      :: ExamplePkgVersion   , exInstHash         :: ExamplePkgHash-  , exInstBuildAgainst :: [ExampleInstalled]-  }+  , exInstBuildAgainst :: [ExamplePkgHash]+  } deriving Show +-- | Constructs an example installed package given:+--+--      1. The name of the package 'ExamplePkgName', i.e., 'String'+--      2. The version of the package 'ExamplePkgVersion', i.e., 'Int'+--      3. The IPID for the package 'ExamplePkgHash', i.e., 'String'+--         (just some unique identifier for the package.)+--      4. The 'ExampleInstalled' packages which this package was+--         compiled against.)+-- exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash        -> [ExampleInstalled] -> ExampleInstalled-exInst = ExInst+exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) +-- | An example package database is a list of installed packages+-- 'ExampleInstalled' and available packages 'ExampleAvailable'.+-- Generally, you want to use 'exInst' and 'exAv' to construct+-- these packages. type ExampleDb = [Either ExampleInstalled ExampleAvailable]  type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a +newtype IndepGoals = IndepGoals Bool+  deriving Show++newtype ReorderGoals = ReorderGoals Bool+  deriving Show+ exDbPkgs :: ExampleDb -> [ExamplePkgName] exDbPkgs = map (either exInstName exAvName) -exAvSrcPkg :: ExampleAvailable -> SourcePackage+exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage exAvSrcPkg ex =-    let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))+    let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex))+        testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]     in SourcePackage {            packageInfoId        = exAvPkgId ex          , packageSource        = LocalTarballPackage "<<path>>"          , packageDescrOverride = Nothing-         , packageDescription   = C.GenericPackageDescription{+         , packageDescription   = C.GenericPackageDescription {                C.packageDescription = C.emptyPackageDescription {                    C.package        = exAvPkgId ex-                 , C.library        = error "not yet configured: library"+                 , C.libraries      = error "not yet configured: library"                  , C.executables    = error "not yet configured: executables"                  , C.testSuites     = error "not yet configured: testSuites"                  , C.benchmarks     = error "not yet configured: benchmarks"@@ -150,47 +224,75 @@                        C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))                      }                  }-             , C.genPackageFlags = concatMap extractFlags-                                   (CD.libraryDeps (exAvDeps ex))-             , C.condLibrary     = Just $ mkCondTree libraryDeps+             , C.genPackageFlags = nub $ concatMap extractFlags $+                                   CD.libraryDeps (exAvDeps ex) ++ concatMap snd testSuites+             , C.condLibraries   = [(exAvName ex, mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs)+                                                     disableLib+                                                     (Buildable libraryDeps))]              , C.condExecutables = []-             , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree deps))-                                   testSuites+             , C.condTestSuites  =+                 let mkTree = mkCondTree mempty disableTest . Buildable+                 in map (\(t, deps) -> (t, mkTree deps)) testSuites              , C.condBenchmarks  = []              }          }   where+    -- Split the set of dependencies into the set of dependencies of the library,+    -- the dependencies of the test suites and extensions.     splitTopLevel :: [ExampleDependency]                   -> ( [ExampleDependency]-                     , [(ExampleTestName, [ExampleDependency])]+                     , [Extension]+                     , Maybe Language+                     , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config                      )-    splitTopLevel []                = ([], [])-    splitTopLevel (ExTest t a:deps) =-      let (other, testSuites) = splitTopLevel deps-      in (other, (t, a):testSuites)-    splitTopLevel (dep:deps)        =-      let (other, testSuites) = splitTopLevel deps-      in (dep:other, testSuites)+    splitTopLevel [] =+        ([], [], Nothing, [])+    splitTopLevel (ExExt ext:deps) =+      let (other, exts, lang, pcpkgs) = splitTopLevel deps+      in (other, ext:exts, lang, pcpkgs)+    splitTopLevel (ExLang lang:deps) =+        case splitTopLevel deps of+            (other, exts, Nothing, pcpkgs) -> (other, exts, Just lang, pcpkgs)+            _ -> error "Only 1 Language dependency is supported"+    splitTopLevel (ExPkg pkg:deps) =+      let (other, exts, lang, pcpkgs) = splitTopLevel deps+      in (other, exts, lang, pkg:pcpkgs)+    splitTopLevel (dep:deps) =+      let (other, exts, lang, pcpkgs) = splitTopLevel deps+      in (dep:other, exts, lang, pcpkgs) +    -- Extract the total set of flags used     extractFlags :: ExampleDependency -> [C.Flag]     extractFlags (ExAny _)      = []     extractFlags (ExFix _ _)    = []     extractFlags (ExFlag f a b) = C.MkFlag {                                       C.flagName        = C.FlagName f                                     , C.flagDescription = ""-                                    , C.flagDefault     = False+                                    , C.flagDefault     = True                                     , C.flagManual      = False                                     }-                                : concatMap extractFlags (a ++ b)-    extractFlags (ExTest _ a)   = concatMap extractFlags a+                                : concatMap extractFlags (deps a ++ deps b)+      where+        deps :: Dependencies -> [ExampleDependency]+        deps NotBuildable = []+        deps (Buildable ds) = ds+    extractFlags (ExExt _)      = []+    extractFlags (ExLang _)     = []+    extractFlags (ExPkg _)      = [] -    mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a-    mkCondTree deps =+    mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a+    mkCondTree x dontBuild NotBuildable =+      C.CondNode {+             C.condTreeData        = dontBuild x+           , C.condTreeConstraints = []+           , C.condTreeComponents  = []+           }+    mkCondTree x dontBuild (Buildable deps) =       let (directDeps, flaggedDeps) = splitDeps deps       in C.CondNode {-             C.condTreeData        = mempty -- irrelevant to the solver-           , C.condTreeConstraints = map mkDirect  directDeps-           , C.condTreeComponents  = map mkFlagged flaggedDeps+             C.condTreeData        = x -- Necessary for language extensions+           , C.condTreeConstraints = map mkDirect directDeps+           , C.condTreeComponents  = map (mkFlagged dontBuild) flaggedDeps            }      mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency@@ -200,17 +302,25 @@         v = Version [n, 0, 0] []      mkFlagged :: Monoid a-              => (ExampleFlagName, [ExampleDependency], [ExampleDependency])+              => (a -> a)+              -> (ExampleFlagName, Dependencies, Dependencies)               -> (C.Condition C.ConfVar                  , DependencyTree a, Maybe (DependencyTree a))-    mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f))-                          , mkCondTree a-                          , Just (mkCondTree b)-                          )+    mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))+                                    , mkCondTree mempty dontBuild a+                                    , Just (mkCondTree mempty dontBuild b)+                                    ) +    -- Split a set of dependencies into direct dependencies and flagged+    -- dependencies. A direct dependency is a tuple of the name of package and+    -- maybe its version (no version means any version) meant to be converted+    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is+    -- the set of dependencies guarded by a flag.+    --+    -- TODO: Take care of flagged language extensions and language flavours.     splitDeps :: [ExampleDependency]               -> ( [(ExamplePkgName, Maybe Int)]-                 , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]+                 , [(ExampleFlagName, Dependencies, Dependencies)]                  )     splitDeps [] =       ([], [])@@ -223,14 +333,34 @@     splitDeps (ExFlag f a b:deps) =       let (directDeps, flaggedDeps) = splitDeps deps       in (directDeps, (f, a, b):flaggedDeps)-    splitDeps (ExTest _ _:_) =-      error "Unexpected nested test"+    splitDeps (_:deps) = splitDeps deps      -- Currently we only support simple setup dependencies     mkSetupDeps :: [ExampleDependency] -> [C.Dependency]     mkSetupDeps deps =       let (directDeps, []) = splitDeps deps in map mkDirect directDeps +    -- A 'C.Library' with just the given extensions in its 'BuildInfo'+    extsLib :: [Extension] -> C.Library+    extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }++    -- A 'C.Library' with just the given extensions in its 'BuildInfo'+    langLib :: Maybe Language -> C.Library+    langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }+    langLib _ = mempty++    disableLib :: C.Library -> C.Library+    disableLib lib =+        lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}++    disableTest :: C.TestSuite -> C.TestSuite+    disableTest test =+        test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}++    -- A 'C.Library' with just the given pkgconfig-depends in its 'BuildInfo'+    pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library+    pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } }+ exAvPkgId :: ExampleAvailable -> C.PackageIdentifier exAvPkgId ex = C.PackageIdentifier {       pkgName    = C.PackageName (exAvName ex)@@ -239,11 +369,9 @@  exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo exInstInfo ex = C.emptyInstalledPackageInfo {-      C.installedPackageId = C.InstalledPackageId (exInstHash ex)+      C.installedUnitId    = C.mkUnitId (exInstHash ex)     , C.sourcePackageId    = exInstPkgId ex-    , C.packageKey         = exInstKey ex-    , C.depends            = map (C.InstalledPackageId . exInstHash)-                                 (exInstBuildAgainst ex)+    , C.depends            = map C.mkUnitId (exInstBuildAgainst ex)     }  exInstPkgId :: ExampleInstalled -> C.PackageIdentifier@@ -252,46 +380,51 @@     , pkgVersion = Version [exInstVersion ex, 0, 0] []     } -exInstLibName :: ExampleInstalled -> C.LibraryName-exInstLibName ex = C.packageKeyLibraryName (exInstPkgId ex) (exInstKey ex)--exInstKey :: ExampleInstalled -> C.PackageKey-exInstKey ex =-    C.mkPackageKey True-                   (exInstPkgId ex)-                   (map exInstLibName (exInstBuildAgainst ex))--exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage+exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg  exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex exInstIdx = C.PackageIndex.fromList . map exInstInfo  exResolve :: ExampleDb+          -- List of extensions supported by the compiler, or Nothing if unknown.+          -> Maybe [Extension]+          -- List of languages supported by the compiler, or Nothing if unknown.+          -> Maybe [Language]+          -> PC.PkgConfigDb           -> [ExamplePkgName]-          -> Bool+          -> Solver+          -> IndepGoals+          -> ReorderGoals+          -> [ExPreference]           -> ([String], Either String CI.InstallPlan.InstallPlan)-exResolve db targets indepGoals = runProgress $+exResolve db exts langs pkgConfigDb targets solver (IndepGoals indepGoals) (ReorderGoals reorder) prefs = runProgress $     resolveDependencies C.buildPlatform-                        (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)-                        Modular+                        compiler pkgConfigDb+                        solver                         params   where+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag+    compiler = defaultCompiler { C.compilerInfoExtensions = exts+                               , C.compilerInfoLanguages  = langs+                               }     (inst, avai) = partitionEithers db     instIdx      = exInstIdx inst     avaiIdx      = SourcePackageDb {                        packageIndex       = exAvIdx avai                      , packagePreferences = Map.empty                      }-    enableTests  = map (\p -> PackageConstraintStanzas+    enableTests  = fmap (\p -> PackageConstraintStanzas                               (C.PackageName p) [TestStanzas])                        (exDbPkgs db)-    targets'     = map (\p -> NamedPackage (C.PackageName p) []) targets-    params       = addConstraints (map toLpc enableTests)-                 $ (standardInstallPolicy instIdx avaiIdx targets') {-                       depResolverIndependentGoals = indepGoals-                     }+    targets'     = fmap (\p -> NamedPackage (C.PackageName p) []) targets+    params       =   addPreferences (fmap toPref prefs)+                   $ addConstraints (fmap toLpc enableTests)+                   $ setIndependentGoals indepGoals+                   $ setReorderGoals reorder+                   $ standardInstallPolicy instIdx avaiIdx targets'     toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown+    toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v  extractInstallPlan :: CI.InstallPlan.InstallPlan                    -> [(ExamplePkgName, ExamplePkgVersion)]@@ -301,10 +434,10 @@     confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg     confPkg _                               = Nothing -    srcPkg :: ConfiguredPackage -> (String, Int)-    srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =+    srcPkg :: ConfiguredPackage UnresolvedPkgLoc -> (String, Int)+    srcPkg cpkg =       let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =-            packageInfoId pkg+            packageInfoId (confPkgSource cpkg)       in (p, n)  {-------------------------------------------------------------------------------
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/QuickCheck.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.Dependency.Modular.QuickCheck (tests) where++import Control.Monad (foldM)+import Data.Either (lefts)+import Data.Function (on)+import Data.List (groupBy, nub, sort)+import Data.Maybe (isJust)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>))+import Data.Monoid (Monoid)+#endif++import Text.Show.Pretty (parseValue, valToStr)++import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck++import qualified Distribution.Client.ComponentDeps as CD+import Distribution.Client.ComponentDeps ( Component(..)+                                         , ComponentDep, ComponentDeps)+import Distribution.Client.Dependency.Types (Solver(..))+import Distribution.Client.PkgConfigDb (pkgConfigDbFromList)++import UnitTests.Distribution.Client.Dependency.Modular.DSL++tests :: [TestTree]+tests = [+      -- This test checks that certain solver parameters do not affect the+      -- existence of a solution. It runs the solver twice, and only sets those+      -- parameters on the second run. The test also applies parameters that+      -- can affect the existence of a solution to both runs.+      testProperty "target order and --reorder-goals do not affect solvability" $+          \(SolverTest db targets) targetOrder reorderGoals indepGoals solver ->+            let r1 = solve (ReorderGoals False) indepGoals solver targets  db+                r2 = solve reorderGoals         indepGoals solver targets2 db+                targets2 = case targetOrder of+                             SameOrder -> targets+                             ReverseOrder -> reverse targets+            in counterexample (showResults r1 r2) $+               isJust (resultPlan r1) === isJust (resultPlan r2)+    ]+  where+    showResults :: Result -> Result -> String+    showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2++    showResult :: Int -> Result -> String+    showResult n result =+        unlines $ ["", "Run " ++ show n ++ ":"]+               ++ resultLog result+               ++ ["result: " ++ show (resultPlan result)]++solve :: ReorderGoals -> IndepGoals -> Solver -> [PN] -> TestDb -> Result+solve reorder indep solver targets (TestDb db) =+  let (lg, result) =+        exResolve db Nothing Nothing+                  (pkgConfigDbFromList [])+                  (map unPN targets)+                  solver indep reorder []+  in Result {+       resultLog = lg+     , resultPlan =+          case result of+            Left _ -> Nothing+            Right plan -> Just (extractInstallPlan plan)+     }++-- | How to modify the order of the input targets.+data TargetOrder = SameOrder | ReverseOrder+  deriving Show++instance Arbitrary TargetOrder where+  arbitrary = elements [SameOrder, ReverseOrder]++  shrink SameOrder = []+  shrink ReverseOrder = [SameOrder]++data Result = Result {+    resultLog :: [String]+  , resultPlan :: Maybe [(ExamplePkgName, ExamplePkgVersion)]+  }++-- | Package name.+newtype PN = PN { unPN :: String }+  deriving (Eq, Ord, Show)++instance Arbitrary PN where+  arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])++-- | Package version.+newtype PV = PV { unPV :: Int }+  deriving (Eq, Ord, Show)++instance Arbitrary PV where+  arbitrary = PV <$> elements [1..10]++type TestPackage = Either ExampleInstalled ExampleAvailable++getName :: TestPackage -> PN+getName = PN . either exInstName exAvName++getVersion :: TestPackage -> PV+getVersion = PV . either exInstVersion exAvVersion++data SolverTest = SolverTest {+    testDb :: TestDb+  , testTargets :: [PN]+  }++-- | Pretty-print the test when quickcheck calls 'show'.+instance Show SolverTest where+  show test =+    let str = "SolverTest {testDb = " ++ show (testDb test)+                     ++ ", testTargets = " ++ show (testTargets test) ++ "}"+    in maybe str valToStr $ parseValue str++instance Arbitrary SolverTest where+  arbitrary = do+    db <- arbitrary+    let pkgs = nub $ map getName (unTestDb db)+    Positive n <- arbitrary+    targets <- randomSubset n pkgs+    return (SolverTest db targets)++  shrink test =+         [test { testDb = db } | db <- shrink (testDb test)]+      ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]++-- | Collection of source and installed packages.+newtype TestDb = TestDb { unTestDb :: ExampleDb }+  deriving Show++instance Arbitrary TestDb where+  arbitrary = do+      -- Avoid cyclic dependencies by grouping packages by name and only+      -- allowing each package to depend on packages in the groups before it.+      groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<+                     boundedListOf 10 arbitrary+      db <- foldM nextPkgs (TestDb []) groupedPkgs+      TestDb <$> shuffle (unTestDb db)+    where+      nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb+      nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs++      nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage+      nextPkg db (pn, v) = do+        installed <- arbitrary+        if installed+        then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)+        else Right <$> arbitraryExAv pn v db++  shrink (TestDb pkgs) = map TestDb $ shrink pkgs++arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable+arbitraryExAv pn v db =+    ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db++arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled+arbitraryExInst pn v pkgs = do+  hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']+  numDeps <- min 3 <$> arbitrary+  deps <- randomSubset numDeps pkgs+  return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps)++arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency])+arbitraryComponentDeps (TestDb []) = return $ CD.fromList []+arbitraryComponentDeps db =+    -- CD.fromList combines duplicate components.+    CD.fromList <$> boundedListOf 3 (arbitraryComponentDep db)++arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])+arbitraryComponentDep db = do+  comp <- arbitrary+  deps <- case comp of+            ComponentSetup -> smallListOf (arbitraryExDep db Setup)+            _              -> boundedListOf 5 (arbitraryExDep db NonSetup)+  return (comp, deps)++-- | Location of an 'ExampleDependency'. It determines which values are valid.+data ExDepLocation = Setup | NonSetup++arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency+arbitraryExDep db@(TestDb pkgs) level =+  let flag = ExFlag <$> arbitraryFlagName+                    <*> arbitraryDeps db+                    <*> arbitraryDeps db+      other = [+            ExAny . unPN <$> elements (map getName pkgs)++          -- existing version+          , let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)+            in fixed <$> elements pkgs++          -- random version of an existing package+          , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)+          ]+  in oneof $+      case level of+        NonSetup -> flag : other+        Setup -> other++arbitraryDeps :: TestDb -> Gen Dependencies+arbitraryDeps db = frequency+    [ (1, return NotBuildable)+    , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetup))+    ]++arbitraryFlagName :: Gen String+arbitraryFlagName = (:[]) <$> elements ['A'..'E']++arbitraryComponentName :: Gen String+arbitraryComponentName = (:[]) <$> elements "ABC"++instance Arbitrary ReorderGoals where+  arbitrary = ReorderGoals <$> arbitrary++  shrink (ReorderGoals reorder) = [ReorderGoals False | reorder]++instance Arbitrary IndepGoals where+  arbitrary = IndepGoals <$> arbitrary++  shrink (IndepGoals indep) = [IndepGoals False | indep]++instance Arbitrary Solver where+  arbitrary = frequency [ (1, return TopDown)+                        , (5, return Modular) ]++  shrink Modular = []+  shrink TopDown = [Modular]++instance Arbitrary Component where+  arbitrary = oneof [ ComponentLib <$> arbitraryComponentName+                    , ComponentExe <$> arbitraryComponentName+                    , ComponentTest <$> arbitraryComponentName+                    , ComponentBench <$> arbitraryComponentName+                    , return ComponentSetup+                    ]++  shrink (ComponentLib "") = []+  shrink _ = [ComponentLib ""]++instance Arbitrary ExampleInstalled where+  arbitrary = error "arbitrary not implemented: ExampleInstalled"++  shrink ei = [ ei { exInstBuildAgainst = deps }+              | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]++instance Arbitrary ExampleAvailable where+  arbitrary = error "arbitrary not implemented: ExampleAvailable"++  shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]++instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where+  arbitrary = error "arbitrary not implemented: ComponentDeps"++  shrink = map CD.fromList . shrink . CD.toList++instance Arbitrary ExampleDependency where+  arbitrary = error "arbitrary not implemented: ExampleDependency"++  shrink (ExAny _) = []+  shrink (ExFix pn _) = [ExAny pn]+  shrink (ExFlag flag th el) =+         deps th ++ deps el+      ++ [ExFlag flag th' el | th' <- shrink th]+      ++ [ExFlag flag th el' | el' <- shrink el]+    where+      deps NotBuildable = []+      deps (Buildable ds) = ds+  shrink dep = error $ "Dependency not handled: " ++ show dep++instance Arbitrary Dependencies where+  arbitrary = error "arbitrary not implemented: Dependencies"++  shrink NotBuildable = [Buildable []]+  shrink (Buildable deps) = map Buildable (shrink deps)++randomSubset :: Int -> [a] -> Gen [a]+randomSubset n xs = take n <$> shuffle xs++boundedListOf :: Int -> Gen a -> Gen [a]+boundedListOf n gen = take n <$> listOf gen++-- | Generates lists with average length less than 1.+smallListOf :: Gen a -> Gen [a]+smallListOf gen =+    frequency [ (fr, vectorOf n gen)+              | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs view
@@ -1,20 +1,27 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options) where+module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests)+       where  -- base import Control.Monad import Data.Maybe (isNothing)-import Data.Proxy-import Data.Typeable +import qualified Data.Version         as V+import qualified Distribution.Version as V+ -- test-framework import Test.Tasty as TF import Test.Tasty.HUnit (testCase, assertEqual, assertBool)-import Test.Tasty.Options +-- Cabal+import Language.Haskell.Extension ( Extension(..)+                                  , KnownExtension(..), Language(..))+ -- cabal-install+import Distribution.Client.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList)+import Distribution.Client.Dependency.Types (Solver(Modular)) import UnitTests.Distribution.Client.Dependency.Modular.DSL+import UnitTests.Options  tests :: [TF.TestTree] tests = [@@ -67,39 +74,155 @@         , runTest $ mkTest db12 "baseShim5" ["D"] Nothing         , runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])         ]+    , testGroup "Cycles" [+          runTest $ mkTest db14 "simpleCycle1"          ["A"]      Nothing+        , runTest $ mkTest db14 "simpleCycle2"          ["A", "B"] Nothing+        , runTest $ mkTest db14 "cycleWithFlagChoice1"  ["C"]      (Just [("C", 1), ("E", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"]      Nothing+        , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"]      Nothing+        , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"]      (Just [("C", 2), ("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"]      (Just [("D", 1)])+        , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"]      (Just [("C", 2), ("D", 1), ("E", 1)])+        ]+    , testGroup "Extensions" [+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (Just [("A",1),("B",1), ("C",1)])+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] Nothing+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] Nothing+        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])+        ]+    , testGroup "Languages" [+          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] Nothing+        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (Just [("A",1)])+        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing+        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])+        ]++     , testGroup "Soft Constraints" [+          runTest $ soft [ ExPref "A" $ mkvrThis 1]      $ mkTest db13 "selectPreferredVersionSimple" ["A"] (Just [("A", 1)])+        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (Just [("A", 2)])+        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 2+                         , ExPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (Just [("A", 1)])+        , runTest $ soft [ ExPref "A" $ mkvrOrEarlier 1+                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (Just [("A", 1)])+        , runTest $ soft [ ExPref "A" $ mkvrThis 1+                         , ExPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (Just [("A", 2)])+        , runTest $ soft [ ExPref "A" $ mkvrThis 1+                         , ExPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (Just [("A", 1)])+        ]+     , testGroup "Buildable Field" [+          testBuildable "avoid building component with unknown dependency" (ExAny "unknown")+        , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))+        , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))+        , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (Just [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])+        , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (Just [("A", 1), ("B", 2)])+         ]+    , testGroup "Pkg-config dependencies" [+          runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] Nothing+        , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] Nothing+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)])+        , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (Just [("A", 1), ("B", 2), ("C", 1)])+        ]     ]   where-    indep test = test { testIndepGoals = True }+    -- | Combinator to turn on --independent-goals behavior, i.e. solve+    -- for the goals as if we were solving for each goal independently.+    -- (This doesn't really work well at the moment, see #2842)+    indep test      = test { testIndepGoals = IndepGoals True }+    soft prefs test = test { testSoftConstraints = prefs }+    mkvrThis        = V.thisVersion . makeV+    mkvrOrEarlier   = V.orEarlierVersion . makeV+    makeV v         = V.Version [v,0,0] []  {-------------------------------------------------------------------------------   Solver tests -------------------------------------------------------------------------------}  data SolverTest = SolverTest {-    testLabel      :: String-  , testTargets    :: [String]-  , testResult     :: Maybe [(String, Int)]-  , testIndepGoals :: Bool-  , testDb         :: ExampleDb+    testLabel          :: String+  , testTargets        :: [String]+  , testResult         :: Maybe [(String, Int)]+  , testIndepGoals     :: IndepGoals+  , testSoftConstraints :: [ExPreference]+  , testDb             :: ExampleDb+  , testSupportedExts  :: Maybe [Extension]+  , testSupportedLangs :: Maybe [Language]+  , testPkgConfigDb    :: PkgConfigDb   } +-- | Makes a solver test case, consisting of the following components:+--+--      1. An 'ExampleDb', representing the package database (both+--         installed and remote) we are doing dependency solving over,+--      2. A 'String' name for the test,+--      3. A list '[String]' of package names to solve for+--      4. The expected result, either 'Nothing' if there is no+--         satisfying solution, or a list '[(String, Int)]' of+--         packages to install, at which versions.+--+-- See 'UnitTests.Distribution.Client.Dependency.Modular.DSL' for how+-- to construct an 'ExampleDb', as well as definitions of 'db1' etc.+-- in this file. mkTest :: ExampleDb        -> String        -> [String]        -> Maybe [(String, Int)]        -> SolverTest-mkTest db label targets result = SolverTest {-    testLabel      = label-  , testTargets    = targets-  , testResult     = result-  , testIndepGoals = False-  , testDb         = db+mkTest = mkTestExtLangPC Nothing Nothing []++mkTestExts :: [Extension]+           -> ExampleDb+           -> String+           -> [String]+           -> Maybe [(String, Int)]+           -> SolverTest+mkTestExts exts = mkTestExtLangPC (Just exts) Nothing []++mkTestLangs :: [Language]+            -> ExampleDb+            -> String+            -> [String]+            -> Maybe [(String, Int)]+            -> SolverTest+mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) []++mkTestPCDepends :: [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> Maybe [(String, Int)]+                -> SolverTest+mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb++mkTestExtLangPC :: Maybe [Extension]+                -> Maybe [Language]+                -> [(String, String)]+                -> ExampleDb+                -> String+                -> [String]+                -> Maybe [(String, Int)]+                -> SolverTest+mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {+    testLabel          = label+  , testTargets        = targets+  , testResult         = result+  , testIndepGoals     = IndepGoals False+  , testSoftConstraints = []+  , testDb             = db+  , testSupportedExts  = exts+  , testSupportedLangs = langs+  , testPkgConfigDb    = pkgConfigDbFromList pkgConfigDb   }  runTest :: SolverTest -> TF.TestTree runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->     testCase testLabel $ do-      let (_msgs, result) = exResolve testDb testTargets testIndepGoals+      let (_msgs, result) = exResolve testDb testSupportedExts+                            testSupportedLangs testPkgConfigDb testTargets+                            Modular testIndepGoals (ReorderGoals False)+                            testSoftConstraints       when showSolverLog $ mapM_ putStrLn _msgs       case result of         Left  err  -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)@@ -139,27 +262,27 @@ db3 = [      Right $ exAv "A" 1 []    , Right $ exAv "A" 2 []-   , Right $ exAv "B" 1 [ExFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]+   , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]    , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]    , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]    ] --- | Like exampleDb2, but the flag picks a different package rather than a+-- | Like db3, but the flag picks a different package rather than a -- different package version ----- In exampleDb2 we cannot install C and D as independent goals because:+-- In db3 we cannot install C and D as independent goals because: -- -- * The multiple instance restriction says C and D _must_ share B--- * Since C relies on A.1, C needs B to be compiled with flagB on--- * Since D relies on A.2, D needs B to be compiled with flagsB off+-- * Since C relies on A-1, C needs B to be compiled with flagB on+-- * Since D relies on A-2, D needs B to be compiled with flagB off -- * Hence C and D have incompatible requirements on B's flags. -- -- However, _even_ if we don't check explicitly that we pick the same flag -- assignment for 0.B and 1.B, we will still detect the problem because -- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to--- 1.B and therefore we cannot link 0.B to 1.B.+-- 1.A and therefore we cannot link 0.B to 1.B. ----- In exampleDb3 the situation however is trickier. We again cannot install+-- In db4 the situation however is trickier. We again cannot install -- packages C and D as independent goals because: -- -- * As above, the multiple instance restriction says that C and D _must_ share B@@ -171,10 +294,10 @@ -- we don't see the problem: -- -- * We link 0.B to 1.B--- * 0.B relies on Ay.1--- * 1.B relies on Ax.1+-- * 0.B relies on Ay-1+-- * 1.B relies on Ax-1 ----- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.A, but since+-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since -- we only ever assign to one of these, these constraints are never broken. db4 :: ExampleDb db4 = [@@ -182,7 +305,7 @@    , Right $ exAv "Ax" 2 []    , Right $ exAv "Ay" 1 []    , Right $ exAv "Ay" 2 []-   , Right $ exAv "B"  1 [ExFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]+   , Right $ exAv "B"  1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]    , Right $ exAv "C"  1 [ExFix "Ax" 2, ExAny "B"]    , Right $ exAv "D"  1 [ExFix "Ay" 2, ExAny "B"]    ]@@ -207,11 +330,11 @@     Right $ exAv "A" 1 []   , Right $ exAv "A" 2 []   , Right $ exAv "B" 1 []-  , Right $ exAv "C" 1 [ExTest "testC" [ExAny "A"]]-  , Right $ exAv "D" 1 [ExTest "testD" [ExFix "B" 2]]-  , Right $ exAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]]-  , Right $ exAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]]-  , Right $ exAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]]+  , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"]+  , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2]+  , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"]+  , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2]+  , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"]   ]  -- Now the _dependencies_ have test suites@@ -226,7 +349,7 @@ db6 = [     Right $ exAv "A" 1 []   , Right $ exAv "A" 2 []-  , Right $ exAv "B" 1 [ExTest "testA" [ExAny "A"]]+  , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"]   , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]   , Right $ exAv "D" 1 [ExAny "B"]   ]@@ -340,21 +463,126 @@     , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]     ] -{--------------------------------------------------------------------------------  Test options--------------------------------------------------------------------------------}+db13 :: ExampleDb+db13 = [+    Right $ exAv "A" 1 []+  , Right $ exAv "A" 2 []+  , Right $ exAv "A" 3 []+  ] -options :: [OptionDescription]-options = [-    Option (Proxy :: Proxy OptionShowSolverLog)+-- | Database with some cycles+--+-- * Simplest non-trivial cycle: A -> B and B -> A+-- * There is a cycle C -> D -> C, but it can be broken by picking the+--   right flag assignment.+db14 :: ExampleDb+db14 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "A"]+  , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]+  , Right $ exAv "D" 1 [ExAny "C"]+  , Right $ exAv "E" 1 []   ] -newtype OptionShowSolverLog = OptionShowSolverLog Bool-  deriving Typeable+-- | Cycles through setup dependencies+--+-- The first cycle is unsolvable: package A has a setup dependency on B,+-- B has a regular dependency on A, and we only have a single version available+-- for both.+--+-- The second cycle can be broken by picking different versions: package C-2.0+-- has a setup dependency on D, and D has a regular dependency on C-*. However,+-- version C-1.0 is already available (perhaps it didn't have this setup dep).+-- Thus, we should be able to break this cycle even if we are installing package+-- E, which explictly depends on C-2.0.+db15 :: ExampleDb+db15 = [+    -- First example (real cycle, no solution)+    Right $ exAv   "A" 1            []            `withSetupDeps` [ExAny "B"]+  , Right $ exAv   "B" 1            [ExAny "A"]+    -- Second example (cycle can be broken by picking versions carefully)+  , Left  $ exInst "C" 1 "C-1-inst" []+  , Right $ exAv   "C" 2            []            `withSetupDeps` [ExAny "D"]+  , Right $ exAv   "D" 1            [ExAny "C"  ]+  , Right $ exAv   "E" 1            [ExFix "C" 2]+  ] -instance IsOption OptionShowSolverLog where-  defaultValue   = OptionShowSolverLog False-  parseValue     = fmap OptionShowSolverLog . safeRead-  optionName     = return "show-solver-log"-  optionHelp     = return "Show full log from the solver"-  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)+dbExts1 :: ExampleDb+dbExts1 = [+    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]+  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]+  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]+  ]++dbLangs1 :: ExampleDb+dbLangs1 = [+    Right $ exAv "A" 1 [ExLang Haskell2010]+  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]+  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]+  ]++-- | cabal must set enable-lib to false in order to avoid the unavailable+-- dependency. Flags are true by default. The flag choice causes "pkg" to+-- depend on "false-dep".+testBuildable :: String -> ExampleDependency -> TestTree+testBuildable testName unavailableDep =+    runTest $ mkTestExtLangPC (Just []) (Just []) [] db testName ["pkg"] expected+  where+    expected = Just [("false-dep", 1), ("pkg", 1)]+    db = [+        Right $ exAv "pkg" 1+            [ unavailableDep+            , ExFlag "enable-lib" (Buildable []) NotBuildable ]+         `withTest`+            ExTest "test" [exFlag "enable-lib"+                              [ExAny "true-dep"]+                              [ExAny "false-dep"]]+      , Right $ exAv "true-dep" 1 []+      , Right $ exAv "false-dep" 1 []+      ]++-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages+-- "flag1-false" and "flag2-true".+dbBuildable1 :: ExampleDb+dbBuildable1 = [+    Right $ exAv "pkg" 1+        [ ExAny "unknown"+        , ExFlag "flag1" (Buildable []) NotBuildable+        , ExFlag "flag2" (Buildable []) NotBuildable]+     `withTests`+        [ ExTest "optional-test"+              [ ExAny "unknown"+              , ExFlag "flag1"+                    (Buildable [])+                    (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]+        , ExTest "test" [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]+                        , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]+        ]+  , Right $ exAv "flag1-true" 1 []+  , Right $ exAv "flag1-false" 1 []+  , Right $ exAv "flag2-true" 1 []+  , Right $ exAv "flag2-false" 1 []+  ]++-- | Package databases for testing @pkg-config@ dependencies.+dbPC1 :: ExampleDb+dbPC1 = [+    Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]+  , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]+  , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]+  , Right $ exAv "C" 1 [ExAny "B"]+  ]++-- | cabal must pick B-2 to avoid the unknown dependency.+dbBuildable2 :: ExampleDb+dbBuildable2 = [+    Right $ exAv "A" 1 [ExAny "B"]+  , Right $ exAv "B" 1 [ExAny "unknown"]+  , Right $ exAv "B" 2+        [ ExAny "unknown"+        , ExFlag "disable-lib" NotBuildable (Buildable [])+        ]+  , Right $ exAv "B" 3 [ExAny "unknown"]+  ]
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs view
@@ -0,0 +1,769 @@+module UnitTests.Distribution.Client.FileMonitor (tests) where++import Control.Monad+import Control.Exception+import Control.Concurrent (threadDelay)+import qualified Data.Set as Set+import System.FilePath+import qualified System.Directory as IO+import Prelude hiding (writeFile)+import qualified Prelude as IO (writeFile)++import Distribution.Text (simpleParse)+import Distribution.Compat.Binary+import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity (silent)++import Distribution.Client.FileMonitor+import Distribution.Client.Compat.Time++import Test.Tasty+import Test.Tasty.HUnit+++tests :: Int -> [TestTree]+tests mtimeChange =+  [ testCase "sanity check mtimes"   $ testFileMTimeSanity mtimeChange+  , testCase "no monitor cache"      testNoMonitorCache+  , testCase "corrupt monitor cache" testCorruptMonitorCache+  , testCase "empty monitor"         testEmptyMonitor+  , testCase "missing file"          testMissingFile+  , testCase "change file"           $ testChangedFile mtimeChange+  , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange+  , testCase "update during action"  $ testUpdateDuringAction mtimeChange+  , testCase "remove file"           testRemoveFile+  , testCase "non-existent file"     testNonExistentFile+  , testCase "changed file type"     $ testChangedFileType mtimeChange++  , testGroup "glob matches"+    [ testCase "no change"           testGlobNoChange+    , testCase "add match"           $ testGlobAddMatch mtimeChange+    , testCase "remove match"        $ testGlobRemoveMatch mtimeChange+    , testCase "change match"        $ testGlobChangeMatch mtimeChange++    , testCase "add match subdir"    $ testGlobAddMatchSubdir mtimeChange+    , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange+    , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange++    , testCase "match toplevel dir"  $ testGlobMatchTopDir mtimeChange+    , testCase "add non-match"       $ testGlobAddNonMatch mtimeChange+    , testCase "remove non-match"    $ testGlobRemoveNonMatch mtimeChange++    , testCase "add non-match"       $ testGlobAddNonMatchSubdir mtimeChange+    , testCase "remove non-match"    $ testGlobRemoveNonMatchSubdir mtimeChange++    , testCase "invariant sorted 1"  $ testInvariantMonitorStateGlobFiles+                                         mtimeChange+    , testCase "invariant sorted 2"  $ testInvariantMonitorStateGlobDirs+                                         mtimeChange++    , testCase "match dirs"          $ testGlobMatchDir mtimeChange+    , testCase "match dirs only"     $ testGlobMatchDirOnly mtimeChange+    , testCase "change file type"    $ testGlobChangeFileType mtimeChange+    , testCase "absolute paths"      $ testGlobAbsolutePath mtimeChange+    ]++  , testCase "value unchanged"       testValueUnchanged+  , testCase "value changed"         testValueChanged+  , testCase "value & file changed"  $ testValueAndFileChanged mtimeChange+  , testCase "value updated"         testValueUpdated+  ]++-- we rely on file mtimes having a reasonable resolution+testFileMTimeSanity :: Int -> Assertion+testFileMTimeSanity mtimeChange =+  withTempDirectory silent "." "file-status-" $ \dir -> do+    replicateM_ 10 $ do+      IO.writeFile (dir </> "a") "content"+      t1 <- getModTime (dir </> "a")+      threadDelay mtimeChange+      IO.writeFile (dir </> "a") "content"+      t2 <- getModTime (dir </> "a")+      assertBool "expected different file mtimes" (t2 > t1)++-- first run, where we don't even call updateMonitor+testNoMonitorCache :: Assertion+testNoMonitorCache =+  withFileMonitor $ \root monitor -> do+    reason <- expectMonitorChanged root (monitor :: FileMonitor () ()) ()+    reason @?= MonitorFirstRun++-- write garbage into the binary cache file+testCorruptMonitorCache :: Assertion+testCorruptMonitorCache =+  withFileMonitor $ \root monitor -> do+    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitorCorruptCache++    updateMonitor root monitor [] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++    IO.writeFile (fileMonitorCacheFile monitor) "broken"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitorCorruptCache++-- no files to monitor+testEmptyMonitor :: Assertion+testEmptyMonitor =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [] () ()+    touchFile root "b"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= []++-- monitor a file that is expected to exist+testMissingFile :: Assertion+testMissingFile = do+    test monitorFile       touchFile  "a"+    test monitorFileHashed touchFile  "a"+    test monitorFile       touchFile ("dir" </> "a")+    test monitorFileHashed touchFile ("dir" </> "a")+    test monitorDirectory  touchDir   "a"+    test monitorDirectory  touchDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch file =+      withFileMonitor $ \root monitor -> do+        -- a file that doesn't exist at snapshot time is considered to have+        -- changed+        updateMonitor root monitor [monitorKind file] () ()+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file++        -- a file doesn't exist at snapshot time, but gets added afterwards is+        -- also considered to have changed+        updateMonitor root monitor [monitorKind file] () ()+        touch root file+        reason2 <- expectMonitorChanged root monitor ()+        reason2 @?= MonitoredFileChanged file+++testChangedFile :: Int -> Assertion+testChangedFile mtimeChange = do+    test monitorFile       touchFile touchFile         "a"+    test monitorFileHashed touchFile touchFileContent  "a"+    test monitorFile       touchFile touchFile        ("dir" </> "a")+    test monitorFileHashed touchFile touchFileContent ("dir" </> "a")+    test monitorDirectory  touchDir  touchDir          "a"+    test monitorDirectory  touchDir  touchDir         ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch touch' file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        threadDelay mtimeChange+        touch' root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testChangedFileMtimeVsContent :: Int -> Assertion+testChangedFileMtimeVsContent mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- if we don't touch the file, it's unchanged+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFile "a"]++    -- if we do touch the file, it's changed if we only consider mtime+    updateMonitor root monitor [monitorFile "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- but if we touch the file, it's unchanged if we consider content hash+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorFileHashed "a"]++    -- finally if we change the content it's changed+    updateMonitor root monitor [monitorFileHashed "a"] () ()+    threadDelay mtimeChange+    touchFileContent root "a"+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"+++testUpdateDuringAction :: Int -> Assertion+testUpdateDuringAction mtimeChange = do+    test (monitorFile        "a") touchFile "a"+    test (monitorFileHashed  "a") touchFile "a"+    test (monitorDirectory   "a") touchDir  "a"+    test (monitorFileGlobStr "*") touchFile "a"+    test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }+                                  touchDir  "a"+  where+    test :: MonitorFilePath+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorSpec touch file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorSpec] () ()++        -- start doing an update action...+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitor root monitor [monitorSpec] () ()+        -- we don't notice this change since we took the timestamp after the+        -- action finished+        (res, files) <- expectMonitorUnchanged root monitor ()+        res   @?= ()+        files @?= [monitorSpec]++        -- Let's try again, this time taking the timestamp before the action+        timestamp' <- beginUpdateFileMonitor+        threadDelay mtimeChange -- some time passes+        touch root file         -- a file gets updates during the action+        threadDelay mtimeChange -- some time passes then we finish+        updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () ()+        -- now we do notice the change since we took the snapshot before the+        -- action finished+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++testRemoveFile :: Assertion+testRemoveFile = do+    test monitorFile       touchFile removeFile  "a"+    test monitorFileHashed touchFile removeFile  "a"+    test monitorFile       touchFile removeFile ("dir" </> "a")+    test monitorFileHashed touchFile removeFile ("dir" </> "a")+    test monitorDirectory  touchDir  removeDir   "a"+    test monitorDirectory  touchDir  removeDir  ("dir" </> "a")+  where+    test :: (FilePath -> MonitorFilePath)+         -> (RootPath -> FilePath -> IO ())+         -> (RootPath -> FilePath -> IO ())+         -> FilePath+         -> IO ()+    test monitorKind touch remove file =+      withFileMonitor $ \root monitor -> do+        touch root file+        updateMonitor root monitor [monitorKind file] () ()+        remove root file+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged file+++-- monitor a file that we expect not to exist+testNonExistentFile :: Assertion+testNonExistentFile =+  withFileMonitor $ \root monitor -> do+    -- a file that doesn't exist at snapshot time or check time is unchanged+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorNonExistentFile "a"]++    -- if the file then exists it has changed+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++    -- if the file then exists at snapshot and check time it has changed+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged "a"++    -- but if the file existed at snapshot time and doesn't exist at check time+    -- it is consider unchanged. This is unlike files we expect to exist, but+    -- that's because files that exist can have different content and actions+    -- can depend on that content, whereas if the action expected a file not to+    -- exist and it now does not, it'll give the same result, irrespective of+    -- the fact that the file might have existed in the meantime.+    updateMonitor root monitor [monitorNonExistentFile "a"] () ()+    removeFile root "a"+    (res2, files2) <- expectMonitorUnchanged root monitor ()+    res2   @?= ()+    files2 @?= [monitorNonExistentFile "a"]+++testChangedFileType :: Int-> Assertion+testChangedFileType mtimeChange = do+    test (monitorFile            "a") touchFile removeFile createDir+    test (monitorFileHashed      "a") touchFile removeFile createDir++    test (monitorDirectory       "a") createDir removeDir touchFile+    test (monitorFileOrDirectory "a") createDir removeDir touchFile++    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      touchFile removeFile createDir+    test (monitorFileGlobStr     "*") { monitorKindDir = DirModTime }+                                      createDir removeDir touchFile+  where+    test :: MonitorFilePath+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> (RootPath -> String -> IO ())+         -> IO ()+    test monitorKind touch remove touch' =+      withFileMonitor $ \root monitor -> do+        touch  root "a"+        updateMonitor root monitor [monitorKind] () ()+        threadDelay mtimeChange+        remove root "a"+        touch' root "a"+        reason <- expectMonitorChanged root monitor ()+        reason @?= MonitoredFileChanged "a"+++------------------+-- globs+--++testGlobNoChange :: Assertion+testGlobNoChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddMatch :: Int -> Assertion+testGlobAddMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobRemoveMatch :: Int -> Assertion+testGlobRemoveMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-a")++testGlobChangeMatch :: Int -> Assertion+testGlobChangeMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++    touchFileContent root ("dir" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "good-b")++testGlobAddMatchSubdir :: Int -> Assertion+testGlobAddMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++testGlobRemoveMatchSubdir :: Int -> Assertion+testGlobRemoveMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a" </> "good-a")++testGlobChangeMatchSubdir :: Int -> Assertion+testGlobChangeMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "good-b")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "good-b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++    touchFileContent root "dir/b/good-b"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b" </> "good-b")++-- check nothing goes squiffy with matching in the top dir+testGlobMatchTopDir :: Int -> Assertion+testGlobMatchTopDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "*"] () ()+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged "a"++testGlobAddNonMatch :: Int -> Assertion+testGlobAddNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobRemoveNonMatch :: Int -> Assertion+testGlobRemoveNonMatch mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "good-a")+    touchFile root ("dir" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()+    threadDelay mtimeChange+    removeFile root "dir/bad"+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/good-*"]++testGlobAddNonMatchSubdir :: Int -> Assertion+testGlobAddNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    touchFile root ("dir" </> "b" </> "bad")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]++testGlobRemoveNonMatchSubdir :: Int -> Assertion+testGlobRemoveNonMatchSubdir mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "good-a")+    touchFile root ("dir" </> "b" </> "bad")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "b")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/good-*"]+++-- try and tickle a bug that happens if we don't maintain the invariant that+-- MonitorStateGlobFiles entries are sorted+testInvariantMonitorStateGlobFiles :: Int -> Assertion+testInvariantMonitorStateGlobFiles mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "d")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- so there should be no change (since we're doing content checks)+    -- but if we can get the dir entries to appear in the wrong order+    -- then if the sorted invariant is not maintained then we can fool+    -- the 'probeGlobStatus' into thinking there's changes+    removeFile root ("dir" </> "a")+    removeFile root ("dir" </> "b")+    removeFile root ("dir" </> "c")+    removeFile root ("dir" </> "d")+    touchFile root ("dir" </> "d")+    touchFile root ("dir" </> "c")+    touchFile root ("dir" </> "b")+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]++-- same thing for the subdirs case+testInvariantMonitorStateGlobDirs :: Int -> Assertion+testInvariantMonitorStateGlobDirs mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root ("dir" </> "a" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "d" </> "file")+    updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    removeDir root ("dir" </> "b")+    removeDir root ("dir" </> "c")+    removeDir root ("dir" </> "d")+    touchFile root ("dir" </> "d" </> "file")+    touchFile root ("dir" </> "c" </> "file")+    touchFile root ("dir" </> "b" </> "file")+    touchFile root ("dir" </> "a" </> "file")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/file"]++-- ensure that a glob can match a directory as well as a file+testGlobMatchDir :: Int -> Assertion+testGlobMatchDir mtimeChange =+  withFileMonitor $ \root monitor -> do+    createDir root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    -- nothing changed yet+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*"]+    -- expect dir/b to match and be detected as changed+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")+    -- now remove dir/a and expect it to be detected as changed+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobMatchDirOnly :: Int -> Assertion+testGlobMatchDirOnly mtimeChange =+  withFileMonitor $ \root monitor -> do+    updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () ()+    threadDelay mtimeChange+    -- expect file dir/a to not match, so not detected as changed+    touchFile root ("dir" </> "a")+    (res, files) <- expectMonitorUnchanged root monitor ()+    res   @?= ()+    files @?= [monitorFileGlobStr "dir/*/"]+    -- note that checking the file monitor for changes can updates the+    -- cached dir mtimes (when it has to record that there's new matches)+    -- so we need an extra mtime delay+    threadDelay mtimeChange+    -- but expect dir/b to match+    createDir root ("dir" </> "b")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "b")++testGlobChangeFileType :: Int -> Assertion+testGlobChangeFileType mtimeChange =+  withFileMonitor $ \root monitor -> do+    -- change file to dir+    touchFile root ("dir" </> "a")+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeFile root ("dir" </> "a")+    createDir  root ("dir" </> "a")+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged ("dir" </> "a")+    -- change dir to file+    updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()+    threadDelay mtimeChange+    removeDir root ("dir" </> "a")+    touchFile root ("dir" </> "a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged ("dir" </> "a")++testGlobAbsolutePath :: Int -> Assertion+testGlobAbsolutePath mtimeChange =+  withFileMonitor $ \root monitor -> do+    root' <- absoluteRoot root+    -- absolute glob, removing a file+    touchFile root ("dir/good-a")+    touchFile root ("dir/good-b")+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    removeFile root "dir/good-a"+    reason <- expectMonitorChanged root monitor ()+    reason @?= MonitoredFileChanged (root' </> "dir/good-a")+    -- absolute glob, adding a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFile root ("dir/good-a")+    reason2 <- expectMonitorChanged root monitor ()+    reason2 @?= MonitoredFileChanged (root' </> "dir/good-a")+    -- absolute glob, changing a file+    updateMonitor root monitor [monitorFileGlobStr (root' </> "dir/good-*")] () ()+    threadDelay mtimeChange+    touchFileContent root "dir/good-b"+    reason3 <- expectMonitorChanged root monitor ()+    reason3 @?= MonitoredFileChanged (root' </> "dir/good-b")+++------------------+-- value changes+--++testValueUnchanged :: Assertion+testValueUnchanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    (res, files) <- expectMonitorUnchanged root monitor 42+    res   @?= "ok"+    files @?= [monitorFile "a"]++testValueChanged :: Assertion+testValueChanged =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++testValueAndFileChanged :: Int -> Assertion+testValueAndFileChanged mtimeChange =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    -- we change the value and the file, and the value change is reported+    updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason <- expectMonitorChanged root monitor 43+    reason @?= MonitoredValueChanged 42++    -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed+    -- then it's reported as MonitoredValueChanged+    let monitor' :: FileMonitor Int String+        monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True }+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    reason2 <- expectMonitorChanged root monitor' 43+    reason2 @?= MonitoredValueChanged 42++    -- but if a file changed too then we don't report MonitoredValueChanged+    updateMonitor root monitor' [monitorFile "a"] 42 "ok"+    threadDelay mtimeChange+    touchFile root "a"+    reason3 <- expectMonitorChanged root monitor' 43+    reason3 @?= MonitoredFileChanged "a"++testValueUpdated :: Assertion+testValueUpdated =+  withFileMonitor $ \root monitor -> do+    touchFile root "a"++    let monitor' :: FileMonitor (Set.Set Int) String+        monitor' = (monitor :: FileMonitor (Set.Set Int) String) {+                     fileMonitorCheckIfOnlyValueChanged = True,+                     fileMonitorKeyValid = Set.isSubsetOf+                   }++    updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok"+    (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])+    res @?= "ok"++    reason <- expectMonitorChanged root monitor' (Set.fromList [42,44])+    reason @?= MonitoredValueChanged (Set.fromList [42,43])+++-------------+-- Utils++newtype RootPath = RootPath FilePath++touchFile :: RootPath -> FilePath -> IO ()+touchFile (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "touched"++touchFileContent :: RootPath -> FilePath -> IO ()+touchFileContent (RootPath root) fname = do+  let path = root </> fname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.writeFile path "different"++removeFile :: RootPath -> FilePath -> IO ()+removeFile (RootPath root) fname = IO.removeFile (root </> fname)++touchDir :: RootPath -> FilePath -> IO ()+touchDir root@(RootPath rootdir) dname = do+  IO.createDirectoryIfMissing True (rootdir </> dname)+  touchFile  root (dname </> "touch")+  removeFile root (dname </> "touch")++createDir :: RootPath -> FilePath -> IO ()+createDir (RootPath root) dname = do+  let path = root </> dname+  IO.createDirectoryIfMissing True (takeDirectory path)+  IO.createDirectory path++removeDir :: RootPath -> FilePath -> IO ()+removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root </> dname)++absoluteRoot :: RootPath -> IO FilePath+absoluteRoot (RootPath root) = IO.canonicalizePath root++monitorFileGlobStr :: String -> MonitorFilePath+monitorFileGlobStr globstr+  | Just glob <- simpleParse globstr = monitorFileGlob glob+  | otherwise                        = error $ "Failed to parse " ++ globstr+++expectMonitorChanged :: (Binary a, Binary b)+                     => RootPath -> FileMonitor a b -> a+                     -> IO (MonitorChangedReason a)+expectMonitorChanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged reason -> return reason+    MonitorUnchanged _ _  -> throwIO $ HUnitFailure "expected change"++expectMonitorUnchanged :: (Binary a, Binary b)+                        => RootPath -> FileMonitor a b -> a+                        -> IO (b, [MonitorFilePath])+expectMonitorUnchanged root monitor key = do+  res <- checkChanged root monitor key+  case res of+    MonitorChanged _reason   -> throwIO $ HUnitFailure "expected no change"+    MonitorUnchanged b files -> return (b, files)++checkChanged :: (Binary a, Binary b)+             => RootPath -> FileMonitor a b+             -> a -> IO (MonitorChanged a b)+checkChanged (RootPath root) monitor key =+  checkFileMonitorChanged monitor root key++updateMonitor :: (Binary a, Binary b)+              => RootPath -> FileMonitor a b+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitor (RootPath root) monitor files key result =+  updateFileMonitor monitor root Nothing files key result++updateMonitorWithTimestamp :: (Binary a, Binary b)+              => RootPath -> FileMonitor a b -> MonitorTimestamp+              -> [MonitorFilePath] -> a -> b -> IO ()+updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =+  updateFileMonitor monitor root (Just timestamp) files key result++withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c+withFileMonitor action = do+  withTempDirectory silent "." "file-status-" $ \root -> do+    let file    = root <.> "monitor"+        monitor = newFileMonitor file+    finally (action (RootPath root) monitor) $ do+      exists <- IO.doesFileExist file+      when exists $ IO.removeFile file
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.Glob (tests) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Char+import Data.List+import Distribution.Text (display, parse, simpleParse)+import Distribution.Compat.ReadP++import Distribution.Client.Glob+import UnitTests.Distribution.Client.ArbitraryInstances++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.HUnit+import Control.Exception+++tests :: [TestTree]+tests =+  [ testProperty "print/parse roundtrip" prop_roundtrip_printparse+  , testCase     "parse examples"        testParseCases+  ]++--TODO: [nice to have] tests for trivial globs, tests for matching,+-- tests for windows style file paths++prop_roundtrip_printparse :: FilePathGlob -> Bool+prop_roundtrip_printparse pathglob =+  -- can't use simpleParse because it mis-handles trailing spaces+  case [ x | (x, []) <- readP_to_S parse (display pathglob) ] of+    xs@(_:_) -> last xs == pathglob+    _        -> False++-- first run, where we don't even call updateMonitor+testParseCases :: Assertion+testParseCases = do++  FilePathGlob FilePathUnixRoot GlobDirTrailing <- testparse "/"+  FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/"++  FilePathGlob (FilePathWinDrive 'A') GlobDirTrailing <- testparse "A:/"+  FilePathGlob (FilePathWinDrive 'Z') GlobDirTrailing <- testparse "z:/"+  FilePathGlob (FilePathWinDrive 'C') GlobDirTrailing <- testparse "C:\\"+  FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "."]) <- testparse "."++  FilePathGlob FilePathRelative+    (GlobFile [Literal "~"]) <- testparse "~"++  FilePathGlob FilePathRelative+    (GlobDir  [Literal "."] GlobDirTrailing) <- testparse "./"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo"]) <- testparse "foo"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobFile [Literal "bar"])) <- testparse "foo/bar"++  FilePathGlob FilePathRelative+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"++  FilePathGlob FilePathUnixRoot+    (GlobDir [Literal "foo"]+      (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard]) <- testparse "*"++  FilePathGlob FilePathRelative+    (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid++  FilePathGlob FilePathRelative+    (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*"++  FilePathGlob FilePathRelative+    (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar"++  FilePathGlob FilePathRelative+    (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}"++  parseFail "{"+  parseFail "}"+  parseFail ","+  parseFail "{"+  parseFail "{{}"+  parseFail "{}"+  parseFail "{,}"+  parseFail "{foo,}"+  parseFail "{,foo}"++  return ()++testparse :: String -> IO FilePathGlob+testparse s =+    case simpleParse s of+      Just p  -> return p+      Nothing -> throwIO $ HUnitFailure ("expected parse of: " ++ s)++parseFail :: String -> Assertion+parseFail s =+    case simpleParse s :: Maybe FilePathGlob of+      Just _  -> throwIO $ HUnitFailure ("expected no parse of: " ++ s)+      Nothing -> return ()++instance Arbitrary FilePathGlob where+  arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary)+                `suchThat` validFilePathGlob++  shrink (FilePathGlob root pathglob) =+    [ FilePathGlob root' pathglob'+    | (root', pathglob') <- shrink (root, pathglob)+    , validFilePathGlob (FilePathGlob root' pathglob') ]++validFilePathGlob :: FilePathGlob -> Bool+validFilePathGlob (FilePathGlob FilePathRelative pathglob) =+  case pathglob of+    GlobDirTrailing             -> False+    GlobDir [Literal "~"] _     -> False+    GlobDir [Literal (d:":")] _ +      | isLetter d              -> False+    _                           -> True+validFilePathGlob _ = True++instance Arbitrary FilePathRoot where+  arbitrary =+    frequency+      [ (3, pure FilePathRelative)+      , (1, pure FilePathUnixRoot)+      , (1, pure FilePathHomeDir)+      , (1, FilePathWinDrive <$> choose ('A', 'Z'))+      ]++  shrink FilePathRelative     = []+  shrink FilePathUnixRoot     = [FilePathRelative]+  shrink FilePathHomeDir      = [FilePathRelative]+  shrink (FilePathWinDrive d) = FilePathRelative+                              : [ FilePathWinDrive d' | d' <- shrink d ]+++instance Arbitrary FilePathGlobRel where+  arbitrary = sized $ \sz ->+    oneof $ take (max 1 sz)+      [ pure GlobDirTrailing+      , GlobFile  <$> (getGlobPieces <$> arbitrary)+      , GlobDir   <$> (getGlobPieces <$> arbitrary)+                  <*> resize (sz `div` 2) arbitrary+      ]++  shrink GlobDirTrailing = []+  shrink (GlobFile glob) =+      GlobDirTrailing+    : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ]+  shrink (GlobDir glob pathglob) =+      pathglob+    : GlobFile glob+    : [ GlobDir (getGlobPieces glob') pathglob'+      | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ]++newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] }+  deriving Eq++instance Arbitrary GlobPieces where+  arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary++  shrink (GlobPieces glob) =+    [ GlobPieces (mergeLiterals (getNonEmpty glob'))+    | glob' <- shrink (NonEmpty glob) ]++mergeLiterals :: [GlobPiece] -> [GlobPiece]+mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps)+mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps+mergeLiterals (p:ps) = p : mergeLiterals ps+mergeLiterals []     = []++instance Arbitrary GlobPiece where+  arbitrary = sized $ \sz ->+    frequency+      [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars))+      , (1, pure WildCard)+      , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary)))+      ]++  shrink (Literal str) = [ Literal str'+                         | str' <- shrink str+                         , not (null str')+                         , all (`elem` globLiteralChars) str' ]+  shrink WildCard       = []+  shrink (Union as)     = [ Union (map getGlobPieces (getNonEmpty as'))+                          | as' <- shrink (NonEmpty (map GlobPieces as)) ]++globLiteralChars :: [Char]+globLiteralChars = ['\0'..'\128'] \\ "*{},/\\"+
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,610 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnitTests.Distribution.Client.ProjectConfig (tests) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+import Control.Applicative+#endif+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List++import Distribution.Package+import Distribution.PackageDescription hiding (Flag)+import Distribution.Compiler+import Distribution.Version+import Distribution.ParseUtils+import Distribution.Simple.Compiler+import Distribution.Simple.Setup+import Distribution.Simple.InstallDirs+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Simple.Utils+import Distribution.Simple.Program.Types+import Distribution.Simple.Program.Db++import Distribution.Client.Types+import Distribution.Client.Dependency.Types+import Distribution.Client.BuildReports.Types+import Distribution.Client.Targets+import Distribution.Utils.NubList+import Network.URI++import Distribution.Client.ProjectConfig+import Distribution.Client.ProjectConfig.Legacy++import UnitTests.Distribution.Client.ArbitraryInstances++import Test.Tasty+import Test.Tasty.QuickCheck++tests :: [TestTree]+tests =+  [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $+    [ testProperty "packages"  prop_roundtrip_legacytypes_packages+    , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly+    , testProperty "specific"  prop_roundtrip_legacytypes_specific+    ] +++    -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older+    -- unclear why as of yet+    concat+    [ [ testProperty "shared"    prop_roundtrip_legacytypes_shared+      , testProperty "local"     prop_roundtrip_legacytypes_local+      , testProperty "all"       prop_roundtrip_legacytypes_all+      ]+    | not usingGhc76orOlder+    ]++  , testGroup "individual parser tests"+    [ testProperty "package location"  prop_parsePackageLocationTokenQ+    ]++  , testGroup "ProjectConfig printing/parsing round trip"+    [ testProperty "packages"  prop_roundtrip_printparse_packages+    , testProperty "buildonly" prop_roundtrip_printparse_buildonly+    , testProperty "shared"    prop_roundtrip_printparse_shared+    , testProperty "local"     prop_roundtrip_printparse_local+    , testProperty "specific"  prop_roundtrip_printparse_specific+    , testProperty "all"       prop_roundtrip_printparse_all+    ]+  ]+  where+    usingGhc76orOlder =+      case buildCompilerId of+        CompilerId GHC v -> v < Version [7,7] []+        _                -> False+++------------------------------------------------+-- Round trip: conversion to/from legacy types+--++roundtrip :: Eq a => (a -> b) -> (b -> a) -> a -> Bool+roundtrip f f_inv x =+    (f_inv . f) x == x++roundtrip_legacytypes :: ProjectConfig -> Bool+roundtrip_legacytypes =+    roundtrip convertToLegacyProjectConfig+              convertLegacyProjectConfig+++prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool+prop_roundtrip_legacytypes_all =+    roundtrip_legacytypes++prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool+prop_roundtrip_legacytypes_packages config =+    roundtrip_legacytypes+      config {+        projectConfigBuildOnly       = mempty,+        projectConfigShared          = mempty,+        projectConfigLocalPackages   = mempty,+        projectConfigSpecificPackage = mempty+      }++prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Bool+prop_roundtrip_legacytypes_buildonly config =+    roundtrip_legacytypes+      mempty { projectConfigBuildOnly = config }++prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Bool+prop_roundtrip_legacytypes_shared config =+    roundtrip_legacytypes+      mempty { projectConfigShared = config }++prop_roundtrip_legacytypes_local :: PackageConfig -> Bool+prop_roundtrip_legacytypes_local config =+    roundtrip_legacytypes+      mempty { projectConfigLocalPackages = config }++prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool+prop_roundtrip_legacytypes_specific config =+    roundtrip_legacytypes+      mempty { projectConfigSpecificPackage = config }+++--------------------------------------------+-- Round trip: printing and parsing config+--++roundtrip_printparse :: ProjectConfig -> Bool+roundtrip_printparse config =+    case (fmap convertLegacyProjectConfig+        . parseLegacyProjectConfig+        . showLegacyProjectConfig+        . convertToLegacyProjectConfig)+          config of+      ParseOk _ x -> x == config+      _           -> False+++prop_roundtrip_printparse_all :: ProjectConfig -> Bool+prop_roundtrip_printparse_all config =+    roundtrip_printparse config {+      projectConfigBuildOnly =+        hackProjectConfigBuildOnly (projectConfigBuildOnly config),++      projectConfigShared =+        hackProjectConfigShared (projectConfigShared config)+    }++prop_roundtrip_printparse_packages :: [PackageLocationString]+                                   -> [PackageLocationString]+                                   -> [SourceRepo]+                                   -> [Dependency]+                                   -> Bool+prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =+    roundtrip_printparse+      mempty {+        projectPackages         = map getPackageLocationString pkglocstrs1,+        projectPackagesOptional = map getPackageLocationString pkglocstrs2,+        projectPackagesRepo     = repos,+        projectPackagesNamed    = named+      }++prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Bool+prop_roundtrip_printparse_buildonly config =+    roundtrip_printparse+      mempty {+        projectConfigBuildOnly = hackProjectConfigBuildOnly config+      }++hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly+hackProjectConfigBuildOnly config =+    config {+      -- These two fields are only command line transitory things, not+      -- something to be recorded persistently in a config file+      projectConfigOnlyDeps = mempty,+      projectConfigDryRun   = mempty+    }++prop_roundtrip_printparse_shared :: ProjectConfigShared -> Bool+prop_roundtrip_printparse_shared config =+    roundtrip_printparse+      mempty {+        projectConfigShared = hackProjectConfigShared config+      }++hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared+hackProjectConfigShared config =+    config {+      projectConfigConstraints =+      --TODO: [required eventually] parse ambiguity in constraint+      -- "pkgname -any" as either any version or disabled flag "any".+        let ambiguous ((UserConstraintFlags _pkg flags), _) =+              (not . null) [ () | (FlagName name, False) <- flags+                                , "any" `isPrefixOf` name ]+            ambiguous _ = False+         in filter (not . ambiguous) (projectConfigConstraints config)+    }+++prop_roundtrip_printparse_local :: PackageConfig -> Bool+prop_roundtrip_printparse_local config =+    roundtrip_printparse+      mempty {+        projectConfigLocalPackages = config+      }++prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)+                                   -> Bool+prop_roundtrip_printparse_specific config =+    roundtrip_printparse+      mempty {+        projectConfigSpecificPackage = fmap getNonMEmpty config+      }+++----------------------------+-- Individual Parser tests +--++prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool+prop_parsePackageLocationTokenQ (PackageLocationString str) =+    case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ+                                         (renderPackageLocationToken str) ] of+      [str'] -> str' == str+      _      -> False+++------------------------+-- Arbitrary instances+--++instance Arbitrary ProjectConfig where+    arbitrary =+      ProjectConfig+        <$> (map getPackageLocationString <$> arbitrary)+        <*> (map getPackageLocationString <$> arbitrary)+        <*> shortListOf 3 arbitrary+        <*> arbitrary+        <*> arbitrary <*> arbitrary+        <*> arbitrary+        <*> (fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary)+        -- package entries with no content are equivalent to+        -- the entry not existing at all, so exclude empty++    shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7) =+      [ ProjectConfig x0' x1' x2' x3' x4' x5' x6' (fmap getNonMEmpty x7')+      | ((x0', x1', x2', x3'), (x4', x5', x6', x7'))+          <- shrink ((x0, x1, x2, x3), (x4, x5, x6, fmap NonMEmpty x7))+      ]++newtype PackageLocationString+      = PackageLocationString { getPackageLocationString :: String }+  deriving Show++instance Arbitrary PackageLocationString where+  arbitrary =+    PackageLocationString <$>+    oneof+      [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))+      , arbitraryGlobLikeStr+      , show <$> (arbitrary :: Gen URI)+      ]++arbitraryGlobLikeStr :: Gen String+arbitraryGlobLikeStr = outerTerm+  where+    outerTerm  = concat <$> shortListOf1 4+                  (frequency [ (2, token)+                             , (1, braces <$> innerTerm) ])+    innerTerm  = intercalate "," <$> shortListOf1 3+                  (frequency [ (3, token)+                             , (1, braces <$> innerTerm) ])+    token      = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))+    braces s   = "{" ++ s ++ "}"+++instance Arbitrary ProjectConfigBuildOnly where+    arbitrary =+      ProjectConfigBuildOnly+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (toNubList <$> shortListOf 2 arbitrary)             --  4+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)                  --  8+        <*> arbitrary+        <*> arbitraryNumJobs+        <*> arbitrary+        <*> arbitrary                                           -- 12+        <*> (fmap getShortToken <$> arbitrary)+        <*> arbitrary+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)                  -- 16+        <*> (fmap getShortToken <$> arbitrary)+        <*> (fmap getShortToken <$> arbitrary)+      where+        arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary++    shrink (ProjectConfigBuildOnly+              x00 x01 x02 x03 x04 x05 x06 x07+              x08 x09 x10 x11 x12 x13 x14 x15+              x16 x17) =+      [ ProjectConfigBuildOnly+          x00' x01' x02' x03' x04'+          x05' x06' x07' x08' (postShrink_NumJobs x09')+          x10' x11' x12  x13' x14+          x15 x16 x17+      | ((x00', x01', x02', x03', x04'),+         (x05', x06', x07', x08', x09'),+         (x10', x11',       x13'))+          <- shrink+               ((x00, x01, x02, x03, x04),+                (x05, x06, x07, x08, preShrink_NumJobs x09),+                (x10, x11,      x13))+      ]+      where+        preShrink_NumJobs  = fmap (fmap Positive)+        postShrink_NumJobs = fmap (fmap getPositive)++instance Arbitrary ProjectConfigShared where+    arbitrary =+      ProjectConfigShared+        <$> (Map.fromList <$> shortListOf 10 +              ((,) <$> arbitraryProgramName+                   <*> arbitraryShortToken))+        <*> (Map.fromList <$> shortListOf 10 +              ((,) <$> arbitraryProgramName+                   <*> listOf arbitraryShortToken))+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitrary                                           --  4+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary                                           --  8+        <*> (toNubList <$> listOf arbitraryShortToken)+        <*> arbitraryConstraints+        <*> arbitrary <*> shortListOf 2 arbitrary               -- 12+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 16+        <*> arbitrary <*> arbitrary+      where+        arbitraryProgramName :: Gen String+        arbitraryProgramName =+          elements [ programName prog+                   | (prog, _) <- knownPrograms (defaultProgramDb) ]++        arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]+        arbitraryConstraints =+            map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary++    shrink (ProjectConfigShared+              x00 x01 x02 x03 x04+              x05 x06 x07 x08 x09+              x10 x11 x12 x13 x14+              x15 x16 x17) =+      [ ProjectConfigShared+          (postShrink_Paths x00')+          (postShrink_Args  x01')+          x02' x03'+          (fmap getNonEmpty x04')+          (fmap getNonEmpty x05')+               x06' x07' x08'+          (postShrink_Constraints x09')+          x10' x11' x12' x13' x14'+          x15' x16' x17'+      | ((x00', x01', x02', x03', x04'),+         (x05', x06', x07', x08', x09'),+         (x10', x11', x12', x13', x14'),+         (x15', x16', x17'))+          <- shrink+               ((preShrink_Paths x00,+                 preShrink_Args  x01,+                 x02, x03, fmap NonEmpty x04),+                (fmap NonEmpty x05, x06, x07, x08, preShrink_Constraints x09),+                (x10, x11, x12, x13, x14),+                (x15, x16, x17))+      ]+      where+        preShrink_Paths  = Map.map NonEmpty . Map.mapKeys NoShrink+        postShrink_Paths = Map.map getNonEmpty . Map.mapKeys getNoShrink+        preShrink_Args   = Map.map (NonEmpty . map NonEmpty)+                         . Map.mapKeys NoShrink+        postShrink_Args  = Map.map (map getNonEmpty . getNonEmpty)+                         . Map.mapKeys getNoShrink+        preShrink_Constraints  = map fst+        postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))++projectConfigConstraintSource :: ConstraintSource+projectConfigConstraintSource = +    ConstraintSourceProjectConfig "TODO"++instance Arbitrary PackageConfig where+    arbitrary =+      PackageConfig+        <$> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             --  4+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             --  8+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 12+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> shortListOf 5 arbitraryShortToken+        <*> arbitrary                                           -- 16+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 20+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 24+        <*> arbitrary <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 28+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitrary <*> arbitrary                             -- 32+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken+        <*> arbitrary+        <*> arbitraryFlag arbitraryShortToken                   -- 36+        <*> arbitrary++    shrink (PackageConfig+              x00 x01 x02 x03 x04+              x05 x06 x07 x08 x09+              x10 x11 x12 x13 x14+              x15 x16 x17 x18 x19+              x20 x21 x22 x23 x24+              x25 x26 x27 x28 x29+              x30 x31 x32 x33 x34+              x35 x36) =+      [ PackageConfig+          x00' x01' x02' x03' x04'+          x05' x06' x07' (map getNonEmpty x08') x09'+          x10' x11'+          (map getNonEmpty x12')+          (map getNonEmpty x13')+          (map getNonEmpty x14')+          x15' x16' x17' x18' x19'+          x20' x21' x22' x23' x24'+          x25' x26' x27' x28' x29'+          x30' x31' x32' (fmap getNonEmpty x33') x34'+          (fmap getNonEmpty x35') x36'+      | (((x00', x01', x02', x03', x04'),+          (x05', x06', x07', x08', x09'),+          (x10', x11', x12', x13', x14'),+          (x15', x16', x17', x18', x19')),+         ((x20', x21', x22', x23', x24'),+          (x25', x26', x27', x28', x29'),+          (x30', x31', x32', x33', x34'),+          (x35', x36')))+          <- shrink+               (((x00, x01, x02, x03, x04),+                 (x05, x06, x07, map NonEmpty x08, x09),+                 (x10, x11,+                  map NonEmpty x12,+                  map NonEmpty x13,+                  map NonEmpty x14),+                 (x15, x16, x17, x18, x19)),+                ((x20, x21, x22, x23, x24),+                 (x25, x26, x27, x28, x29),+                 (x30, x31, x32, fmap NonEmpty x33, x34),+                 (fmap NonEmpty x35, x36)))+      ]+++instance Arbitrary SourceRepo where+    arbitrary = (SourceRepo RepoThis+                           <$> arbitrary+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary)+                           <*> (fmap getShortToken <$> arbitrary))+                `suchThat` (/= emptySourceRepo)++    shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) =+      [ repo+      | ((x1', x2', x3'), (x4', x5', x6'))+          <- shrink ((x1,+                      fmap ShortToken x2,+                      fmap ShortToken x3),+                     (fmap ShortToken x4,+                      fmap ShortToken x5,+                      fmap ShortToken x6))+      , let repo = SourceRepo RepoThis x1'+                              (fmap getShortToken x2')+                              (fmap getShortToken x3')+                              (fmap getShortToken x4')+                              (fmap getShortToken x5')+                              (fmap getShortToken x6')+      , repo /= emptySourceRepo+      ]++emptySourceRepo :: SourceRepo+emptySourceRepo = SourceRepo RepoThis Nothing Nothing Nothing+                                      Nothing Nothing Nothing+++instance Arbitrary RepoType where+    arbitrary = elements knownRepoTypes++instance Arbitrary ReportLevel where+    arbitrary = elements [NoReports .. DetailedReports]++instance Arbitrary CompilerFlavor where+    arbitrary = elements knownCompilerFlavors+      where+        --TODO: [code cleanup] export knownCompilerFlavors from D.Compiler+        -- it's already defined there, just need it exported.+        knownCompilerFlavors =+          [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]++instance Arbitrary a => Arbitrary (InstallDirs a) where+    arbitrary =+      InstallDirs+        <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  4+        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary --  8+        <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12+        <*> arbitrary <*> arbitrary                             -- 14++instance Arbitrary PackageDB where+    arbitrary = oneof [ pure GlobalPackageDB+                      , pure UserPackageDB+                      , SpecificPackageDB . getShortToken <$> arbitrary+                      ]++instance Arbitrary RemoteRepo where+    arbitrary =+      RemoteRepo+        <$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`))+        <*> arbitrary  -- URI+        <*> arbitrary+        <*> listOf arbitraryRootKey+        <*> (fmap getNonNegative arbitrary)+        <*> pure False+      where+        arbitraryRootKey =+          shortListOf1 5 (oneof [ choose ('0', '9')+                                , choose ('a', 'f') ])++instance Arbitrary UserConstraint where+    arbitrary =+      oneof+        [ UserConstraintVersion   <$> arbitrary <*> arbitrary+        , UserConstraintInstalled <$> arbitrary+        , UserConstraintSource    <$> arbitrary+        , UserConstraintFlags     <$> arbitrary <*> shortListOf1 3 arbitrary+        , UserConstraintStanzas   <$> arbitrary <*> ((\x->[x]) <$> arbitrary)+        ]++instance Arbitrary OptionalStanza where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary FlagName where+    arbitrary = FlagName <$> flagident+      where+        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)+                      `suchThat` (("-" /=) . take 1)+        flagChars   = "-_" ++ ['a'..'z']++instance Arbitrary PreSolver where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary AllowNewer where+    arbitrary = oneof [ pure AllowNewerNone+                      , AllowNewerSome <$> shortListOf1 3 arbitrary+                      , pure AllowNewerAll+                      ]++instance Arbitrary AllowNewerDep where+    arbitrary = oneof [ AllowNewerDep       <$> arbitrary+                      , AllowNewerDepScoped <$> arbitrary <*> arbitrary+                      ]++instance Arbitrary ProfDetailLevel where+    arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]++instance Arbitrary OptimisationLevel where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary DebugInfoLevel where+    arbitrary = elements [minBound..maxBound]++instance Arbitrary URI where+    arbitrary =+      URI <$> elements ["file:", "http:", "https:"]+          <*> (Just <$> arbitrary)+          <*> (('/':) <$> arbitraryURIToken)+          <*> (('?':) <$> arbitraryURIToken)+          <*> pure ""++instance Arbitrary URIAuth where+    arbitrary =+      URIAuth <$> pure ""   -- no password as this does not roundtrip+              <*> arbitraryURIToken+              <*> arbitraryURIPort++arbitraryURIToken :: Gen String+arbitraryURIToken =+    shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))++arbitraryURIPort :: Gen String+arbitraryURIPort =+    oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]+
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs view
@@ -0,0 +1,63 @@+module UnitTests.Distribution.Client.Sandbox.Timestamp (tests) where++import System.FilePath++import Distribution.Simple.Utils (withTempDirectory)+import Distribution.Verbosity++import Distribution.Client.Compat.Time+import Distribution.Client.Sandbox.Timestamp++import Test.Tasty+import Test.Tasty.HUnit++tests :: [TestTree]+tests =+  [ testCase "timestamp record version 1 can be read" timestampReadTest_v1+  , testCase "timestamp record version 2 can be read" timestampReadTest_v2+  , testCase "written timestamp record can be read"   timestampReadWriteTest ]++timestampRecord_v1 :: String+timestampRecord_v1 =+  "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" +++  ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]\n"++timestampRecord_v2 :: String+timestampRecord_v2 =+  "2\n" +++  "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" +++  ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]"++timestampReadTest_v1 :: Assertion+timestampReadTest_v1 =+  timestampReadTest timestampRecord_v1 $+  map (\(i, ts) ->+        (i, map (\(p, ModTime t) ->+                  (p, posixSecondsToModTime . fromIntegral $ t)) ts))+  timestampRecord++timestampReadTest_v2 :: Assertion+timestampReadTest_v2 = timestampReadTest timestampRecord_v2 timestampRecord++timestampReadTest :: FilePath -> [TimestampFileRecord] -> Assertion+timestampReadTest fileContent expected =+  withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do+    let fileName = dir </> "timestamp-record"+    writeFile fileName fileContent+    tRec <- readTimestampFile fileName+    assertEqual "expected timestamp records to be equal"+      expected tRec++timestampRecord :: [TimestampFileRecord]+timestampRecord =+  [("i386-linux-ghc-8.0.0.20160204",[("/foo/bar/Baz",ModTime 1455350946)])+  ,("i386-linux-ghc-7.10.3",[("/foo/bar/Baz",ModTime 1455484719)])]++timestampReadWriteTest :: Assertion+timestampReadWriteTest =+  withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do+    let fileName = dir </> "timestamp-record"+    writeTimestampFile fileName timestampRecord+    tRec <- readTimestampFile fileName+    assertEqual "expected timestamp records to be equal"+      timestampRecord tRec
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs view
@@ -0,0 +1,75 @@+module UnitTests.Distribution.Client.Tar (+  tests+  ) where++import Distribution.Client.Tar ( filterEntries+                               , filterEntriesM+                               )+import Codec.Archive.Tar       ( Entries(..)+                               , foldEntries+                               )+import Codec.Archive.Tar.Entry ( EntryContent(..)+                               , simpleEntry+                               , Entry(..)+                               , toTarPath+                               )++import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Control.Monad.Writer.Lazy (runWriterT, tell)++tests :: [TestTree]+tests = [ testCase "filterEntries" filterTest+        , testCase "filterEntriesM" filterMTest+        ]++filterTest :: Assertion+filterTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let (NormalFile dta _) = entryContent e+                     str = BS.Char8.unpack dta+                 in not . (=="y") $ str)+  assertEqual "Unexpected result for filter" "xz" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filter" "z" $+    entriesToString $ filterEntries p $ Done+  assertEqual "Unexpected result for filter" "xf" $+    entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f"++filterMTest :: Assertion+filterMTest = do+  let e1 = getFileEntry "file1" "x"+      e2 = getFileEntry "file2" "y"+      p = (\e -> let (NormalFile dta _) = entryContent e+                     str = BS.Char8.unpack dta+                 in tell "t" >> return (not . (=="y") $ str))++  (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done+  assertEqual "Unexpected result for filterM" "xz" $ entriesToString r+  assertEqual "Unexpected result for filterM w" "tt" w++  (r1, w1) <- runWriterT $ filterEntriesM p $ Done+  assertEqual "Unexpected result for filterM" "z" $ entriesToString r1+  assertEqual "Unexpected result for filterM w" "" w1++  (r2, w2) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 $ Fail "f"+  assertEqual "Unexpected result for filterM" "xf" $ entriesToString r2+  assertEqual "Unexpected result for filterM w" "tt" w2++getFileEntry :: FilePath -> [Char] -> Entry+getFileEntry pth dta =+  simpleEntry tp $ NormalFile dta' $ BS.length dta'+  where  tp = case toTarPath False pth of+           Right tp' -> tp'+           Left e -> error e+         dta' = BS.Char8.pack dta++entriesToString :: Entries String -> String+entriesToString =+  foldEntries (\e acc -> let (NormalFile dta _) = entryContent e+                             str = BS.Char8.unpack dta+                          in str ++ acc) "z" id
cabal/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -4,21 +4,24 @@     ) where  import Control.Exception (bracket)+import Control.Monad (replicateM_) import Data.List (sort, nub) #if !MIN_VERSION_base(4,8,0) import Data.Monoid #endif-import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing)-import System.FilePath (takeDirectory)+import System.Directory (doesFileExist,+                         getCurrentDirectory, getTemporaryDirectory)+import System.FilePath ((</>))  import Test.Tasty import Test.Tasty.HUnit -import Distribution.Compat.Environment (lookupEnv, setEnv) import Distribution.Client.Config import Distribution.Utils.NubList (fromNubList) import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))-import Distribution.Simple.Setup (ConfigFlags (..), fromFlag)+import Distribution.Client.Utils (removeExistingFile)+import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag)+import Distribution.Simple.Utils (withTempDirectory) import Distribution.Verbosity (silent)  tests :: [TestTree]@@ -26,51 +29,48 @@         , testCase "canDetectDifference" canDetectDifference         , testCase "canUpdateConfig" canUpdateConfig         , testCase "doubleUpdateConfig" doubleUpdateConfig+        , testCase "newDefaultConfig" newDefaultConfig         ]  nullDiffOnCreateTest :: Assertion-nullDiffOnCreateTest = bracketTest . const $ do+nullDiffOnCreateTest = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty+    _ <- loadConfig silent (Flag configFile)     -- Now we read it in and compare it against the default.-    diff <- userConfigDiff mempty+    diff <- userConfigDiff $ globalFlags configFile     assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff   canDetectDifference :: Assertion-canDetectDifference = bracketTest . const $ do+canDetectDifference = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty-    cabalFile <- defaultConfigFile-    appendFile cabalFile "verbose: 0\n"-    diff <- userConfigDiff mempty+    _ <- loadConfig silent (Flag configFile)+    appendFile configFile "verbose: 0\n"+    diff <- userConfigDiff $ globalFlags configFile     assertBool (unlines $ "Should detect a difference:" : diff) $         diff == [ "- verbose: 1", "+ verbose: 0" ]   canUpdateConfig :: Assertion-canUpdateConfig = bracketTest . const $ do-    cabalFile <- defaultConfigFile-    createDirectoryIfMissing True $ takeDirectory cabalFile+canUpdateConfig = bracketTest $ \configFile -> do     -- Write a trivial cabal file.-    writeFile cabalFile "tests: True\n"+    writeFile configFile "tests: True\n"     -- Update the config file.-    userConfigUpdate silent mempty+    userConfigUpdate silent $ globalFlags configFile     -- Load it again.-    updated <- loadConfig silent mempty+    updated <- loadConfig silent (Flag configFile)     assertBool ("Field 'tests' should be True") $         fromFlag (configTests $ savedConfigureFlags updated)   doubleUpdateConfig :: Assertion-doubleUpdateConfig = bracketTest . const $ do+doubleUpdateConfig = bracketTest $ \configFile -> do     -- Create a new default config file in our test directory.-    _ <- loadConfig silent mempty-    -- Update it.-    userConfigUpdate silent mempty-    userConfigUpdate silent mempty+    _ <- loadConfig silent (Flag configFile)+    -- Update it twice.+    replicateM_ 2 . userConfigUpdate silent $ globalFlags configFile     -- Load it again.-    updated <- loadConfig silent mempty+    updated <- loadConfig silent (Flag configFile)      assertBool ("Field 'remote-repo' doesn't contain duplicates") $         listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)@@ -80,24 +80,33 @@         listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)  +newDefaultConfig :: Assertion+newDefaultConfig = do+    sysTmpDir <- getTemporaryDirectory+    withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do+        let configFile  = tmpDir </> "tmp.config"+        createDefaultConfigFile silent configFile+        exists <- doesFileExist configFile+        assertBool ("Config file should be written to " ++ configFile) exists+++globalFlags :: FilePath -> GlobalFlags+globalFlags configFile = mempty { globalConfigFile = Flag configFile }++ listUnique :: Ord a => [a] -> Bool listUnique xs =     let sorted = sort xs     in nub sorted == xs  -bracketTest :: ((FilePath, FilePath) -> IO ()) -> Assertion+bracketTest :: (FilePath -> IO ()) -> Assertion bracketTest =     bracket testSetup testTearDown   where-    testSetup :: IO (FilePath, FilePath)-    testSetup = do-        Just oldHome <- lookupEnv "HOME"-        testdir <- fmap (++ "/test-user-config") getCurrentDirectory-        setEnv "HOME" testdir-        return (oldHome, testdir)+    testSetup :: IO FilePath+    testSetup = fmap (</> "test-user-config") getCurrentDirectory -    testTearDown :: (FilePath, FilePath) -> IO ()-    testTearDown (oldHome, testdir) = do-        setEnv "HOME" oldHome-        removeDirectoryRecursive testdir+    testTearDown :: FilePath -> IO ()+    testTearDown configFile =+        mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
+ cabal/cabal-install/tests/UnitTests/Options.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveDataTypeable #-}++module UnitTests.Options ( OptionShowSolverLog(..)+                         , OptionMtimeChangeDelay(..)+                         , extraOptions )+       where++import Data.Proxy+import Data.Typeable++import Test.Tasty.Options++{-------------------------------------------------------------------------------+  Test options+-------------------------------------------------------------------------------}++extraOptions :: [OptionDescription]+extraOptions =+  [ Option (Proxy :: Proxy OptionShowSolverLog)+  , Option (Proxy :: Proxy OptionMtimeChangeDelay)+  ]++newtype OptionShowSolverLog = OptionShowSolverLog Bool+  deriving Typeable++instance IsOption OptionShowSolverLog where+  defaultValue   = OptionShowSolverLog False+  parseValue     = fmap OptionShowSolverLog . safeRead+  optionName     = return "show-solver-log"+  optionHelp     = return "Show full log from the solver"+  optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)++newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int+  deriving Typeable++instance IsOption OptionMtimeChangeDelay where+  defaultValue   = OptionMtimeChangeDelay 0+  parseValue     = fmap OptionMtimeChangeDelay . safeRead+  optionName     = return "mtime-change-delay"+  optionHelp     = return $ "How long to wait before attempting to detect"+                   ++ "file modification, in microseconds"
cabal/setup-dev.sh view
@@ -6,45 +6,31 @@     exit 1 } -build_and_test() {-   # Find sandbox location-   local PACKAGEDB=`cabal exec -- sh -c 'echo $GHC_PACKAGE_PATH' | sed 's/:.*//'`-   echo "Cabal package DB location: $PACKAGEDB"-   # Do the building-  ./Setup configure --enable-tests --package-db="$PACKAGEDB" || die "$1 'configure' failed"-  ./Setup build || die "$1 'build' failed"-# Disabled for now: Tests fail on my system for some reason-#  ./Setup test || die "$1 'test' failed"-}--install_deps() {-   cabal install --only-dependencies --enable-tests || die "$1: Could not install needed dependencies"-}--create_setup() {-   ghc --make -threaded Setup.hs || die "$1: Could not create 'Setup' executable"-}--init_sandbox() {-   cabal sandbox delete # Ignore error status; probably just means sandbox doesn't exist-   cabal sandbox init || die "$1: Could not initialize sandbox"-}--setup_cabal() {-   init_sandbox Cabal-   install_deps Cabal-   create_setup Cabal-   build_and_test Cabal-}--setup_cabalinstall() {-   init_sandbox cabal-install-   cabal sandbox add-source ../Cabal/ || die "cabal-install: Failed to add ../Cabal source"-   install_deps cabal-install-   create_setup cabal-install-   build_and_test cabal-install+setup() {+    # Extract parameters+    local NAME="$1"+    shift+    local DEPS="$@"+    # (Re-)create sandbox+    cabal sandbox delete # Ignore error status; probably just means sandbox doesn't exist+    cabal sandbox init || die "$NAME: Could not initialize sandbox"+    # Add dependencies+    for DEP in $DEPS; do+        cabal sandbox add-source "$DEP"+    done+    # Install dependencies+    cabal install --only-dependencies --enable-tests || die "$NAME: Could not install needed dependencies"+    # Build the 'Setup' executable+    ghc --make -threaded -i -i. Setup.hs || die "$NAME: Could not create 'Setup' executable"+    # Build the package+    local PACKAGEDB=`cabal exec -- sh -c 'echo $GHC_PACKAGE_PATH' | sed 's/:.*//'`+    echo "Cabal package DB location: $PACKAGEDB"+    ./Setup configure --enable-tests --package-db="$PACKAGEDB" || die "$NAME: 'configure' failed"+    ./Setup build || die "$NAME: 'build' failed"+    # Run tests+    ./Setup test || die "$1 'test' failed" }  # Build-(cd ${SCRIPT_DIR}/Cabal         && setup_cabal       ) || die "Failed to build Cabal"-(cd ${SCRIPT_DIR}/cabal-install && setup_cabalinstall) || die "Failed to build cabal-install"+(cd ${SCRIPT_DIR}/Cabal         && setup "Cabal"                 ) || die "Failed to build Cabal"+(cd ${SCRIPT_DIR}/cabal-install && setup "cabal-install" ../Cabal) || die "Failed to build cabal-install"
+ cabal/travis-script.sh view
@@ -0,0 +1,91 @@+#!/usr/bin/env bash+set -ev++# Initial working directory: base directory of Git repository++# We depend on parsec nowadays, which isn't distributed with GHC <8.0+if [ "$PARSEC_BUNDLED" != "YES" ]; then+    cabal install parsec+fi++# ---------------------------------------------------------------------+# Cabal+# ---------------------------------------------------------------------++cd Cabal++# Test if gen-extra-source-files.sh was run recently enough+./misc/gen-extra-source-files.sh Cabal.cabal+./misc/travis-diff-files.sh++cd ../cabal-install+../Cabal/misc/gen-extra-source-files.sh cabal-install.cabal+../Cabal/misc/travis-diff-files.sh++cd ../Cabal++# Build the setup script in the same way that cabal-install would:+mkdir -p ./dist/setup+cp Setup.hs ./dist/setup/setup.hs+ghc --make \+    -odir ./dist/setup -hidir ./dist/setup -i -i. \+    ./dist/setup/setup.hs -o ./dist/setup/setup \+    -Wall -Werror -threaded++# Install test dependencies only after setup is built+cabal install --only-dependencies --enable-tests --enable-benchmarks+./dist/setup/setup configure \+    --user --ghc-option=-Werror --enable-tests --enable-benchmarks \+    -v2 # -v2 provides useful information for debugging++# Build all libraries and executables (including tests/benchmarks)+./dist/setup/setup build+./dist/setup/setup haddock # see https://github.com/haskell/cabal/issues/2198+./dist/setup/setup test --show-details=streaming --test-option=--hide-successes++# Redo the package tests with different versions of GHC+if [ "$TEST_OLDER" == "YES" ]; then+    CABAL_PACKAGETESTS_WITH_GHC=/opt/ghc/7.0.4/bin/ghc \+        ./dist/setup/setup test package-tests --show-details=streaming+    CABAL_PACKAGETESTS_WITH_GHC=/opt/ghc/7.2.2/bin/ghc \+        ./dist/setup/setup test package-tests --show-details=streaming+fi++cabal check+cabal sdist   # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be+# built & installed.+function install_from_tarball {+   export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   if [ -f "dist/$SRC_TGZ" ]; then+      cabal install -j1 "dist/$SRC_TGZ" -v2;+   else+      echo "expected 'dist/$SRC_TGZ' not found";+      exit 1;+   fi+}++install_from_tarball++# ---------------------------------------------------------------------+# cabal-install+# ---------------------------------------------------------------------++cd ../cabal-install++cabal install happy+cabal install --only-dependencies --enable-tests --enable-benchmarks+cabal configure \+    --user --ghc-option=-Werror --enable-tests --enable-benchmarks \+    -v2 # -v2 provides useful information for debugging+cabal build+cabal haddock # see https://github.com/haskell/cabal/issues/2198+cabal test unit-tests --show-details=streaming --test-option=--hide-successes+cabal test integration-tests --show-details=streaming --test-option=--hide-successes+cabal check+./dist/setup/setup sdist+install_from_tarball++# Check what we got+$HOME/.cabal/bin/cabal --version
+ hackage-security/.git view
@@ -0,0 +1,1 @@+gitdir: ../.git/modules/hackage-security
+ hackage-security/.gitignore view
@@ -0,0 +1,5 @@+tags+prototype-state/client/+prototype-state/server/+prototype-state/offline/+.stack-work/
+ hackage-security/.travis.yml view
@@ -0,0 +1,125 @@+# see also https://github.com/hvr/multi-ghc-travis+language: c+sudo: false++cache:+  directories:+    - $HOME/.cabsnap+    - $HOME/.cabal/packages++before_cache:+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar++matrix:+  include:+# cabal 1.16's solver is too weak for GHC 7.4+    - env: CABALVER=1.22 GHCVER=7.4.2+      compiler: ": #GHC 7.4.2"+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.4.2], sources: [hvr-ghc]}}+    - env: CABALVER=1.16 GHCVER=7.6.3+      compiler: ": #GHC 7.6.3"+      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}+    - env: CABALVER=1.18 GHCVER=7.8.4+      compiler: ": #GHC 7.8.4"+      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}+    - env: CABALVER=1.22 GHCVER=7.10.2+      compiler: ": #GHC 7.10.2"+      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}++before_install:+ - unset CC+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH+ - TARGETS="hackage-security/ hackage-security-curl/ hackage-security-HTTP/ hackage-root-tool/ hackage-repo-tool/ example-client/ hackage-security-http-client/";++install:+# Compute install plan (which we use as a travis cache key)+ - cabal --version+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];+   then+     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >+          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;+   fi+ - travis_retry cabal update -v+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config+ - cabal install --constraint="directory installed" --constraint="bytestring installed" --only-dependencies --enable-tests --dry -v $TARGETS > installplan.txt+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt++# check whether current requested install-plan matches cached package-db snapshot+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;+   then+     echo "cabal build-cache HIT";+     rm -rfv .ghc;+     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;+     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;+   else+     echo "cabal build-cache MISS";+     rm -rf $HOME/.cabsnap;+     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;+     cabal install --constraint="directory installed" --constraint="bytestring installed" --only-dependencies --enable-tests $TARGETS;+   fi++# snapshot package-db on cache miss+ - if [ ! -d $HOME/.cabsnap ];+   then+      echo "snapshotting package-db to build-cache";+      mkdir $HOME/.cabsnap;+      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;+      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;+   fi++# Here starts the actual work to be performed for the package under test;+# any command which exits with a non-zero exit code causes the build to fail.+script:+ - cd hackage-security/+ - cabal configure --enable-tests -v2+ - cabal build+ - cabal sdist+ - cabal test+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd hackage-security-curl/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd hackage-security-HTTP/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd hackage-root-tool/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd hackage-repo-tool/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd hackage-security-http-client/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++ - cd example-client/+ - cabal configure -v2+ - cabal build+ - cabal sdist+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ - cd ..++# EOF
+ hackage-security/README.md view
@@ -0,0 +1,694 @@+# Hackage Security++This is a library for Hackage security based on [TUF, The Update+Framework][TUF].++## Project phases and shortcuts++Phase 1 of the project will implement the basic TUF framework, but leave out+author signing; support for author signed packages (and other targets) will+added in phase 2. The main goal of phase 1 is to be able to have untrusted+mirrors of the Hackage server.++## Brief overview of Hackage and cabal-install++Hackage makes all packages available from a single directory `/package`; for+example, version 1.0 of package Foo is available at `/package/Foo-1.0.tar.gz`+(see [Footnote: Paths](#paths)).++Additionally, Hackage offers a tarball, variously known as &ldquo;the+index&rdquo; or &ldquo;the index tarball&rdquo;, located at `/00-index.tar.gz`.+The index tarball contains the `.cabal` for all packages available on the+server; `cabal-install` downloads this file whenever you call `cabal update` to+figure out which packages are available, and it uses this file when you `cabal+install` a package to figure out which dependencies to install. The `.cabal`+file for Foo-1.0 is located at `Foo/1.0/Foo.cabal` in the index. (One side goal+of the Hackage Security project is to make downloading the index incremental.)++Note that although Hackage additionally offers the (latest version of) the+`.cabal` file at `/package/Foo-1.0/Foo.cabal`, this is never used by+`cabal-install`.++In order to distinguish between paths on the server and paths in the index we+will qualify them as `<repo>/package/Foo-1.0.tar.gz` and+`<index>/Foo/1.0/Foo.cabal` respectively, both informally in this text and in+formal delegation rules.++## Comparison with TUF++In this section we highlight some of the differences in the specifics of the+implementation; generally we try to follow the TUF model as closely as+possible.++This section is not (currently) intended to be complete.++### Targets++In the current proposal we do not yet implement author signing, but when we do+implement author signing we want to have a smooth transition, and moreover we+want to be able to have a mixture of packages, some of which are author signed+and some of which are not. That is, package authors must be able to opt-in to+author signing (or not).++#### Unsigned packages++##### Package specific metadata++The package metadata files (&ldquo;target files&rdquo;) will be stored _in the+index_. The metadata for Foo 1.0 will be stored in+`<index>/Foo/1.0/package.json`, and will contain the hash and size of the+package tarball:++``` javascript+{ "signed" : {+     "_type"   : "Targets"+   , "version" : VERSION+   , "expires" : never+   , "targets" : { "<repo>/package/Foo-1.0.tar.gz" : FILEINFO }+   }+, "signatures" : []+}+```++Note that expiry dates are relevant only for information that we expect to+change over time (such as the snapshot). Since packages are immutable, they+cannot expire. (Additionally, there is no point adding an expiry date to files+that are protected only the snapshot key, as the snapshot _itself_ will expire).++It is not necessary to list the file info of the `.cabal` files here: `.cabal`+files are listed by value in the index tarball, and are therefore already+protected by the snapshot key (but see [author signing](#author-signing)).++##### Delegation++[Conceptually speaking](#phase1-shortcuts) we then need a top-level target file+`<index>/targets.json` that contains the required delegation information:++``` javascript+{ "signed" : {+      "_type"       : Targets+    , "version"     : VERSION+    , "expires"     : never+    , "targets"     : []+    , "delegations" : {+          "keys"  : []+        , "roles" : [+               { "name"      : "<index>/$NAME/$VERSION/package.json"+               , "keyids"    : []+               , "threshold" : 0+               , "path"      : "<repo>/package/$NAME-$VERSION.tar.gz"+               }+             ]+       }+    }+, "signatures" : /* target keys */+}+```++This file itself is signed by the target keys (kept offline by the Hackage+admins).  ++Note that this file uses various extension to TUF spec:++* We can use wildcards in names as well as in paths. This means that we list a+  <b>single</b> path with a <b>single</b> replacement name. (Alternatively, we+  could have a list of pairs of paths and names.)+* Paths contain namespaces (`<repo>` versus `<index>`)+* Wildcards have more structure than TUF provides for.++The first one of these is the most important, as it has some security+implications; see comments below.++New unsigned packages, as well as new versions of existing unsigned packages,+can be uploaded to Hackage without any intervention from the Hackage admins (the+offline target keys are not required).++##### Security++This setup is sufficient to allow for untrusted mirrors: since they do not have+access to the snapshot key, they (or a man-in-the-middle) cannot change which+packages are visible or change the packages themselves.++However, since the snapshot key is stored on the server, if the server itself is+compromised almost all security guarantees are void.++#### <a name="author-signing">Signed packages</a>++We sketch the design here only, we do not actually intend to implement this yet+in phase 1 of the project.++##### Package specific metadata++As for unsigned packages, we keep metadata specific for each package version.+Unlike for unsigned packages, however, we store two files: one that can be+signed by the package author, and one that can be signed by the Hackage+trustees, who can upload new `.cabal` file revisions but not change the+package contents.++As before we still have `<index>/Foo/1.0/package.json` containing++``` javascript+{ "signed" : {+     "_type"   : "Targets"+   , "version" : VERSION+   , "expires" : never+   , "targets" : { "<repo>/package/Foo-1.0.tar.gz" : FILEINFO }+   }+, "signatures" : /* signatures from package authors */+}+```++It is not necessary to separately sign the `.cabal` file that is listed _inside_+the package `.tar.gz` file. However, this `.cabal` file may not match the one in+the index, either because a Hackage trustee uploaded a revision, or because of+an malicious attempt to fool the solver in installing different dependencies+than intended.++Therefore, unlike for unsigned packages, listing the file info for the `.cabal`+file in the index is useful for signed packages: although the `.cabal` files are+listed by value in the index tarball, the index is only signed by the snapshot+key. We may want to additionally check that the `.cabal` are properly author+signed too. We record this in a different file `<index>/Foo/1.0/revisions.json`,+which can be signed by either the package authors or the Hackage trustees.++``` javascript+{ "signed" : {+     "_type"   : "Targets"+   , "version" : VERSION+   , "expires" : never+   , "targets" : { "<index>/Foo/1.0/Foo.cabal" : FILEINFO }+   }+, "signatures" : /* signatures from package authors or Hackage trustees */+}+```++##### Delegation++Delegation for signed packages is a bit more complicated. We extend the+top-level targets file to++``` javascript+{ "signed" : {+      "_type"       : Targets+    , "version"     : VERSION+    , "expires"     : EXPIRES+    , "targets"     : []+    , "delegations" : {+          "keys"  : /* Hackage trustee keys */+        , "roles" : [+               // Delegation for unsigned packages+               { "name"      : "<index>/$NAME/$VERSION/package.json"+               , "keyids"    : []+               , "threshold" : 0+               , "path"      : "<repo>/package/$NAME-$VERSION.tar.gz"+               }+             // Delegation for package Bar+             , { "name"      : "<index>/Bar/authors.json"+               , "keyids"    : /* top-level target keys */+               , "threshold" : THRESHOLD+               , "path"      : "<repo>/package/Bar-$VERSION.tar.gz"+               }+             , { "name"      : "<index>/Bar/authors.json"+               , "keyids"    : /* top-level target keys */+               , "threshold" : THRESHOLD+               , "path"      : "<index>/Bar/$VERSION/Bar.cabal"+               }+             , { "name"      : "<index>/Bar/$VERSION/revisions.json"+               , "keyids"    : /* Hackage trustee key IDs  */+               , "threshold" : THRESHOLD+               , "path"      : "<index>/Bar/$VERSION/Bar.cabal"+               }+             // .. delegation for other signed packages ..+             ]+        }+    }+, "signatures" : /* target keys */+}+```++Since this lists all signed packages, we must list an expiry date here so that+attackers cannot mount freeze attacks (although this is somewhat less of an+issue here as freezing this list would make an entire new package, rather than+a new package version, invisible).++This &ldquo;middle level&rdquo; targets file `<index>/Bar/authors.json`+introduces the package author/maintainer keys and contains further delegation+information:++``` javascript+{ "signed" : {+      "_type"       : "Targets"+    , "version"     : VERSION+    , "expires"     : never+    , "targets"     : {}+    , "delegations" : {+          "keys"  : /* package maintainer keys */+        , "roles" : [+              { "name"      : "<index>/Bar/$VERSION/package.json"+              , "keyids"    : /* package maintainer key IDs */+              , "threshold" : THRESHOLD+              , "path"      : "<repo>/Bar/$VERSION/Bar-$VERSION.tar.gz"+              }+            , { "name"      : "<index>/Bar/$VERSION/revisions.json"+              , "keyids"    : /* package maintainer key IDs */+              , "threshold" : THRESHOLD+              , "path"      : "<index>/Bar/$VERSION/Bar.cabal"+              }+            ]+    }+, "signatures" : /* signatures from top-level target keys */+}+```++Some notes:++1. When a new signed package is introduced, the Hackage admins need to create+   and sign a new `targets.json` that lists the package author keys and+   appropriate delegation information, as well as add corresponding entries to+   the top-level delegation file. However, once this is done, the Hackage admins+   do not need to be involved when package authors wish to upload new versions.++2. When package authors upload a new version, they need to sign only a single+   file that contains the information about that particular version.++3. Both package authors (through the package-specific &ldquo;middle level&rdquo;+   delegation information) and Hackage trustees (through the top-level+   delegation information) can sign `.cabal` file revisions, but only authors+   can sign the packages themselves.++4. Hackage trustees are listed only in the top-level delegation information, so+   when the set of trustees changes we only need to modify one file (as opposed+   to each middle-level package delegation information).++5. For signed packages that do not want to allow Hackage trustees to sign+   `.cabal` file revisions we can just omit the corresponding entry from the+   top-level delegations file.++6. There are two kinds of rule overlaps in these delegation rules:+   `<repo>/package/Bar-1.0.tar.gz` will match against the rule for unsigned+   packages (`<repo>/package/$NAME-$VERSION.tar.gz`) and against the rule for+   signed packages (`<repo>/package/Bar-$VERSION.tar.gz`). It is important+   here that the signed rule take precedence, because author signed packages+   _must_ be author signed. The priority scheme can be simple: more specific+   rules should take precedence (the TUF specification leaves the priority+   scheme used open).++   The second kind of overlap occurs between the rule+   for the `.cabal` file in the the top-level `targets.json` and the+   corresponding rule in `authors.json`; in this case both rules match against+   precisely the same path (`<index>/Bar/$VERSION/Bar.cabal`), and indeed in+   this case there is no priority: as long as either rule matches+   (that is, the file is either signed by a package author or by a Hackage+   trustee) we're okay.++##### Transition packages from `unsigned` to `signed`++When a package that previously did not opt-in to author signing now wants+author-signing, we just need to add the appropriate entries to the top-level+delegation file and set up the appropriate middle-level delegation information.++##### Security++When the snapshot key is compromised, attackers still do not have access to+package author keys, which are strictly kept offline. However, they can still+mount freeze attacks on packages versions, because there is no file (which is+signed with offline key) listing which versions are available.++We could increase security here by changing the middle-level `authors.json` to+remove the wildcard rule, list all versions explicitly, and change the top-level+delegation information to say that the middle-level file should be signed by+the package authors instead.++Note that we do not use a wildcard for signed packages in the top-level+`targets.json` for a similar reason: by listing all packages that we expect to+be signed explicitly, we have a list of signed packages which is signed by+offline keys (in this case, the target keys).++### Snapshot++#### Interaction with the index tarball++According to the official specification we should have a file `snapshot.json`,+signed with the snapshot key, which lists the hashes of _all_ metadata files in+the repo. In Hackage however we have the index tarball, which _contains_ most of+the metadata files in the repo (that is, it contains all the `.cabal` files, but+it also contains all the various `.json` files). The only thing that is missing+from the index tarball, compared to the `snapshot.json` file from the TUF spec,+is the version, expiry time, and signatures. Therefore our `snapshot.json` looks+like++``` javascript+{ "signed" : {+      "_type"   : "Snapshot"+    , "version" : VERSION+    , "expires" : EXPIRES+    , "meta"    : {+           "root.json"    : FILEINFO+         , "mirrors.json" : FILEINFO+         , "index.tar"    : FILEINFO+         , "index.tar.gz" : FILEINFO+        }+    }+, "signatures" : /* signatures from snapshot key */+}+```++Then the combination of `snapshot.json` together with the index tarball is+a strict superset of the information in TUF's `snapshot.json` (instead of+containing the hashes of the metadata in the repo, it contains the actual+metadata themselves).++We list the file info of the root and mirrors metadata explicitly, rather than+recording it in the index tarball, so that we can check them for updates during+the update process  (section 5.1, &ldquo;The Client Application&rdquo;, of the+TUF spec) without downloading the entire index tarball.++### Out-of-tarball targets++All versions of all packages are listed, along with their full `.cabal` file, in+the Hackage index. This is useful because the constraint solver needs most of+this information anyway. However, when we add additional kinds of targets we may+not wish to add these to the index: people who are not interested in these new+targets should not, or only minimally, be affected. In particular, new releases+of these new kinds of targets should not result in a linear increase in what+clients who are not interested in these targets need to download whenever they+call `cabal install`.++To support these out-of-tarball targets we can use the regular TUF setup. Since+the index does not serve as an exhaustive list of which targets (and which+target versions) are available, it becomes important to have target metadata+that list all targets exhaustively, to avoid freeze attacks. The file+information (hash and filesize) of all these target metadata files must, by the+TUF spec, be listed in the top-level snapshot; we should thus avoid introducing+too many of them (in particular, we should avoid requiring a new metadata file+for each new version of a particular kind of target).++It is important to store OOT targets under a different prefix than `/package` to+avoid name clashes.++#### Collections++[Package collections][CabalHell1] are a new Hackage feature that's [currently in+development][ZuriHac]. We want package collections to be signed, just like+anything else.++Like packages, collections are versioned and immutable, so we have++```+collection/StackageNightly-2015.06.02.collection+collection/StackageNightly-2015.06.03.collection+collection/StackageNightly-...+collection/DebianJessie-...+collection/...+```++As for packages, collections should be able to opt-in for author signing (once+we support author signing), but we should also support not-author-signed+(&ldquo;unsigned&rdquo;) collections. Moreover, it should be possible for people+to create new unsigned collections without the involvement of the Hackage+admins. This rules out listing all collections explicitly in the top-level+`targets.json` (which is signed with offline target keys).++Below we sketch a possible design (we may want to tweak this further).++##### Unsigned collections++For unsigned collections we add a single delegation rule to the top-level+`targets.json`:++``` javascript+{ "name"      : "<repo>/collection/collections.json"+, "keyids"    : /* snapshot key */+, "threshold" : 1+, "path"      : "<repo>/collection/$NAME-$VERSION.collection"+}+```++The middle-level `collections.json`, signed with the snapshot role, lists+delegation rules for all available collections:++``` javascript+[ { "name"      : "<repo>/collection/StackageNightly.json"+  , "keyids"    : /* snapshot key */+  , "threshold" : 1+  , "path"      : "<repo>/collection/StackageNightly-$VERSION.collection"+  }+, { "name"      : "<repo>/collection/DebianJessie.json"+  , "keyids"    : /* snapshot key */+  , "threshold" : 1+  , "path"      : "<repo>/collection/DebianJessie-$VERSION.collection"+  }+, ...+]+```++where `StackageNightly` and `DebianJessie` are two package collection (the+[Stackage Nightly][StackageNightly] collection and the set of Haskell package+distributed with the [Debian Jessie][DebianJessie] Linux distribution).++The final per-collection targets metadata finally lists all versions:++``` javascript+{ "signed" : {+     "_type"   : "Targets"+   , "version" : VERSION+   , "expires" : /* expiry */+   , "targets" : {+         "<repo>/collection/StackageNightly-2015.06.02.collection" : FILEINFO+       , "<repo>/collection/StackageNightly-2015.06.03.collection" : FILEINFO+       , ...+       }+   }+, "signatures" : /* signed with snapshot role */+}+```++Since we cannot rely on the index to have the list of all version we must list+all versions explicitly here rather than using wildcards. Note that this means+that the snapshot will get a new entry for each new collection introduced, but+not for each new _version_ of each collection.++##### Author-signed collections++For author-signed collections we only need to make a single change. Suppose that+the `DebianJessie` collection is signed. Then we move the rule for+`DebianJessie` from `collection/collections.json` and instead list it in the+top-level `targets.json` (as for packages, introducing a signed collection+necessarily requires the involvement of the Hackage admins):++``` javascript+{ "name"      : "<repo>/collection/DebianJessie.json"+, "keyids"    : /* DebianJessie maintainer keys */+, "threshold" : /* threshold */+, "path"      : "<repo>/collection/DebianJessie-$VERSION.collection"+}+```++No other changes are required (apart from of course that+`<repo>/collection/DebianJessie.json` will now be signed with the+`DebianJessie` maintainer keys rather than the snapshot key). As for packages,+this requires a priority scheme for delegation rules.++(One difference between this scheme and the scheme we use for packages is that+this means that the top-level `targets.json` file lists all keys for all+collection authors. If we want to avoid that we need a further level of+indirection.)++Note that in a sense author-signed collections are snapshots of the server. As+such, it would be good if these collections listed the file info (hashes and+filesizes) of the packages the collection.++## Project phases and shortcuts++Phase 1 of the project will implement the basic TUF framework, but leave out+author signing; support for author signed packages (and other targets) will+added in phase 2.++### <a name="phase1-shortcuts">Shortcuts taken in phase 1 (aka TODOs for phase 2)</a>++This list is currenty not exhaustive.++#### Core library++* Although the infrastructure is in place for [target metadata][Targetshs],+  including typed data types representing [pattern matches and+  replacements][Patternshs], we have not yet actually implementing target+  delegation proper. We don't need to: we only support one kind of target+  (not-author-signed packages), and we know statically where the target+  information for packages can be found (in `/package/version/targets.json`).+  This is currently hardcoded.  ++  Once we have author signing we need a proper implementation of delegation,+  including a priority scheme between rules. This will also involve lazily+  downloading additional target metadata.++* Out-of-tarballs targets are not yet implemented. The main difficulty here is+  that they require a proper implementation of delegation; once that is done+  (required anyway for author signing) support for OOT targets should be+  straightforward.++#### Integration in `cabal-install`++* The cabal integration uses the `hackage-security` library to check for updates+  (that is, update the local copy of the index) and to download packages+  (verifying the downloaded file against the file info that was recorded in+  the package metadata, which itself is stored in the index). However, it does+  not use the library to get a list of available packages, nor to access+  `.cabal` files.++  Once we have author signing however we may want to do additional checks:++  * We should look at the top-level `targets.json` file (in addition to the+    index) to figure out which packages are available. (The top-level targets+    file, signed by offline keys, will enumerate all author-signed packages.)++  * If we do allow package authors to sign list of package versions (as detailed+    above) we should use these &ldquo;middle level&rdquo; target files to figure+    out which versions are available for these packages.++  * We might want to verify the `.cabal` files to make sure that they match the+    file info listed in the now author-signed metadata.++  Therefore `cabal-install` should be modified to go through the+  `hackage-security`  library get the list of available packages, package+  versions, and to access the actual `.cabal` files.++## Open questions / TODOs++* The set of maintainers of a package can change over time, and can even change+  so much that the old maintainers of a package are no longer maintainters.+  But we would still like to be able to install and verify old packages. How+  do we deal with this?++## <a name="paths">Footnotes</a>++### Footnote: Paths++The situation with paths in cabal/hackage is a bit of a mess. In this footnote+we describe the situation before the work on the Hackage Security library.++#### The index tarball++The index tarball contains paths of the form++```+<package-name>/<package-version>/<package-name>.cabal+```++For example:++```+mtl/1.0/mtl.cabal+```++as well as a single top-level `preferred-versions` file.++#### Package resources offered by Hackage++Hackage offers a number of resources for package tarballs: one+&ldquo;official&rdquo; one and a few redirects.++1.  The official location of package tarballs on a Hackage server is++    ```+    /package/<package-id>/<package-id>.tar.gz+    ```++    for example++    ```+    /package/mtl-2.2.1/mtl-2.2.1.tar.gz+    ```++    (This was the official location from [very early on][63a8c728]).++2.  It [provides a redirect][3cfe4de] for++    ```+    /package/<package-id>.tar.gz+    ```++    for example++    ```+    /package/mtl-2.2.1.tar.gz+    ```++    (that is, a request for `/package/mtl-2.2.1.tar.gz` will get a 301 Moved+    Permanently response, and is redirected to+    `/package/mtl-2.2.1/mtl-2.2.1.tar.gz`).++3.  It provides a redirect for Hackage-1 style URLs of the form++    ```+    /packages/archive/<package-name>/<package-version>/<package-id>.tar.gz+    ```++    for example++    ```+    /packages/archive/mtl/2.2.1/mtl-2.2.1.tar.gz+    ```++#### Locations used by cabal-install to find packages++There are two kinds of repositories supported by `cabal-install`: local and+remote.++1.  For a local repository `cabal-install` looks for packages at++    ```+    <local-dir>/<package-name>/<package-version>/<package-id>.tar.gz+    ```++2.  For remote repositories however `cabal-install` looks for packages in one of+    two locations.++    a.  If the remote repository (`<repo>`) is+        `http://hackage.haskell.org/packages/archive` (this value is hardcoded)+        then it looks for the package at++        <repo>/<package-name>/<package-version>/<package-id>.tar.gz++    b.  For any other repository it looks for the package at++        <repo>/package/<package-id>.tar.gz++Some notes:++1.  Files downloaded from a remote repository are cached locally as++    ```+    <cache>/<package-name>/<package-version>/<package-id>.tar.gz+    ```++    I.e., the layout of the local cache matches the layout of a local+    repository (and matches the structure of the index tarball too).++2.  Somewhat bizarrely, when `cabal-install` creates a new initial `config`+    file it uses `http://hackage.haskell.org/packages/archive` as the repo base+    URI (even in newer versions of `cabal-install`; this was [changed only very+    recently][bfeb01f]).++3.  However, notice that _even when we give `cabal` a &ldquo;new-style&rdquo;+    URI_ the address used by `cabal` _still_ causes a redirect (from+    `/package/<package-id>.tar.gz` to+    `/package/<package-id>/<package-id>.tar.gz`).++The most important observation however is the following: **It is not possible to+serve a local repository as a remote repository** (by poining a webserver at a+local repository) because the layouts are completely different. (Note that the+location of packages on Hackage-1 _did_ match the layout of local repositories,+but that doesn't help because the _only_ repository that `cabal-install` will+regard as a Hackage-1 repository is one hosted on `hackage.haskell.org`).++[TUF]: http://theupdateframework.com/+[CabalHell1]: http://www.well-typed.com/blog/2014/09/how-we-might-abolish-cabal-hell-part-1/+[ZuriHac]: http://www.well-typed.com/blog/2015/06/cabal-hackage-hacking-at-zurihac/+[StackageNightly]: http://www.stackage.org/+[DebianJessie]: https://wiki.debian.org/DebianJessie+[Targetshs]: https://github.com/well-typed/hackage-security/blob/master/hackage-security/src/Hackage/Security/TUF/Targets.hs+[Patternshs]: https://github.com/well-typed/hackage-security/blob/master/hackage-security/src/Hackage/Security/TUF/Patterns.hs+[bfeb01f]: https://github.com/haskell/cabal/commit/bfeb01f+[63a8c728]: https://github.com/haskell/hackage-server/commit/63a8c728+[3cfe4de]: https://github.com/haskell/hackage-server/commit/3cfe4de
+ hackage-security/example-client/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/example-client/example-client.cabal view
@@ -0,0 +1,48 @@+name:                example-client+version:             0.1.0.0+synopsis:            Example client using the Hackage security library+-- description:+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++flag use-network-uri+  description: Are we using network-uri?+  manual: False++executable example-client+  main-is:             Main.hs+  other-modules: Prelude ExampleClient.Options++  build-depends:       base                 >= 4.4,+                       bytestring           >= 0.9,+                       Cabal                >= 1.12,+                       directory            >= 1.1,+                       filepath             >= 1.2,+                       optparse-applicative >= 0.11,+                       time                 >= 1.2,+                       hackage-security     >= 0.5,+                       hackage-security-HTTP,+                       hackage-security-curl,+                       hackage-security-http-client+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveDataTypeable+                       FlexibleContexts+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+  other-extensions:    CPP+  ghc-options:         -Wall++  -- see comments in hackage-security.cabal+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6
+ hackage-security/example-client/src/ExampleClient/Options.hs view
@@ -0,0 +1,171 @@+module ExampleClient.Options (+    GlobalOpts(..)+  , Command(..)+  , NewOnly+  , getOptions+    -- * Re-exports+  , URI+  ) where++import Data.List (isPrefixOf)+import Network.URI (URI, parseURI)+import Options.Applicative+import System.IO.Unsafe (unsafePerformIO)++import Distribution.Package+import Distribution.Text++import Hackage.Security.Client+import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++data GlobalOpts = GlobalOpts {+    -- | Path to the repository (local or remote)+    globalRepo :: Either (Path Absolute) URI++    -- | Directory to store the client cache+  , globalCache :: Path Absolute++    -- | HTTP client to use+  , globalHttpClient :: String++    -- | Trusted root key (used for bootstrapping)+  , globalRootKeys :: [KeyId]++    -- | Should we check expiry times?+  , globalCheckExpiry :: Bool++    -- | Command to execute+  , globalCommand :: Command+  }++data Command =+    -- | Get initial root info+    Bootstrap KeyThreshold++    -- | Check for updates on the server+  | Check++    -- | Download a specific package+  | Get PackageIdentifier++    -- | Enumerate the entries in the index+  | EnumIndex NewOnly++    -- | Extract a cabal file from the index+  | GetCabal PackageIdentifier++    -- | Read a package hash from the index+  | GetHash PackageIdentifier+  deriving Show++type NewOnly = Bool++{-------------------------------------------------------------------------------+  Parsers+-------------------------------------------------------------------------------}++getOptions :: IO GlobalOpts+getOptions = execParser opts+  where+    opts = info (helper <*> parseGlobalOptions) $ mconcat [+        fullDesc+      , header "Example Hackage client"+      ]++parseBootstrap :: Parser Command+parseBootstrap = Bootstrap <$> argument readKeyThreshold (metavar "THRESHOLD")++parseCheck :: Parser Command+parseCheck = pure Check++parseGet :: Parser Command+parseGet = Get <$> argument readPackageIdentifier (metavar "PKG")++parseEnumIndex :: Parser Command+parseEnumIndex = EnumIndex+  <$> (switch $ mconcat [+      long "new-only"+    , help "Only enumerate entries since last call to enum-index"+    ])++parseGetCabal :: Parser Command+parseGetCabal = GetCabal <$> argument readPackageIdentifier (metavar "PKG")++parseGetHash :: Parser Command+parseGetHash = GetHash <$> argument readPackageIdentifier (metavar "PKG")++parseGlobalOptions :: Parser GlobalOpts+parseGlobalOptions = GlobalOpts+  <$> (option (str >>= readRepo) $ mconcat [+          long "repo"+        , metavar "URL"+        , help "Location of the repository"+        ])+  <*> (option (str >>= readAbsolutePath) $ mconcat [+          long "cache"+        , metavar "PATH"+        , help "Path to client cache"+        ])+  <*> (strOption $ mconcat [+         long "http-client"+       , metavar "CLIENT"+       , value "HTTP"+       , showDefault+       , help "HTTP client to use (currently supported: HTTP, http-conduit, curl)"+       ])+  <*> (many . option readKeyId $ mconcat [+         long "root-key"+       , metavar "KEYID"+       , help "Root key (used for bootstrapping; can be used multiple times)"+       ])+  <*> (switch $ mconcat [+         long "ignore-expiry"+       , help "Don't check expiry dates (should only be used in exceptional circumstances)"+       ])+  <*> (subparser $ mconcat [+          command "bootstrap" $ info (helper <*> parseBootstrap) $+            progDesc "Get the initial root information. If using a key threshold larger than 0, you will need to use the --root-key option to specify one or more trusted root keys."+        , command "check" $ info (helper <*> parseCheck) $+            progDesc "Check for updates"+        , command "get" $ info (helper <*> parseGet) $+            progDesc "Download a package"+        , command "enum-index" $ info (helper <*> parseEnumIndex) $+            progDesc "Enumerate the index"+        , command "cabal" $ info (helper <*> parseGetCabal) $+            progDesc "Extract a cabal file from the index"+        , command "hash" $ info (helper <*> parseGetHash) $+            progDesc "Read a package hash from the index"+        ])++readKeyId :: ReadM KeyId+readKeyId = KeyId <$> str++readKeyThreshold :: ReadM KeyThreshold+readKeyThreshold = KeyThreshold <$> auto++readPackageIdentifier :: ReadM PackageIdentifier+readPackageIdentifier = do+    raw <- str+    case simpleParse raw of+      Just pkgId -> return pkgId+      Nothing    -> fail $ "Invalid package ID " ++ show raw++-- Sadly, cannot do I/O actions inside ReadM+readAbsolutePath :: String -> ReadM (Path Absolute)+readAbsolutePath = return . unsafePerformIO . makeAbsolute . fromFilePath++readRepo :: String -> ReadM (Either (Path Absolute) URI)+readRepo filePath =+    if "http://" `isPrefixOf` filePath+      then Right <$> readURI filePath+      else Left <$> readAbsolutePath filePath++readURI :: String -> ReadM URI+readURI uriStr =+   case parseURI uriStr of+     Nothing  -> fail $ "Invalid URI " ++ show uriStr+     Just uri -> return uri
+ hackage-security/example-client/src/Main.hs view
@@ -0,0 +1,182 @@+module Main where++-- stdlib+import Control.Exception+import Control.Monad+import Data.Time+import qualified Data.ByteString.Lazy as BS.L++-- Cabal+import Distribution.Package++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some+import Hackage.Security.Client.Repository.HttpLib+import qualified Hackage.Security.Client.Repository.Cache       as Cache+import qualified Hackage.Security.Client.Repository.Local       as Local+import qualified Hackage.Security.Client.Repository.Remote      as Remote+import qualified Hackage.Security.Client.Repository.HttpLib.HTTP as HttpLib.HTTP+import qualified Hackage.Security.Client.Repository.HttpLib.Curl as HttpLib.Curl+import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HttpLib.HttpClient++-- example-client+import ExampleClient.Options++main :: IO ()+main = do+    opts@GlobalOpts{..} <- getOptions+    case globalCommand of+      Bootstrap threshold -> cmdBootstrap opts threshold+      Check               -> cmdCheck     opts+      Get       pkgId     -> cmdGet       opts pkgId+      EnumIndex newOnly   -> cmdEnumIndex opts newOnly+      GetCabal  pkgId     -> cmdGetCabal  opts pkgId+      GetHash   pkgId     -> cmdGetHash   opts pkgId++{-------------------------------------------------------------------------------+  The commands are just thin wrappers around the hackage-security Client API+-------------------------------------------------------------------------------}++cmdBootstrap :: GlobalOpts -> KeyThreshold -> IO ()+cmdBootstrap opts threshold =+    withRepo opts $ \rep -> uncheckClientErrors $ do+      bootstrap rep (globalRootKeys opts) threshold+      putStrLn "OK"++cmdCheck :: GlobalOpts -> IO ()+cmdCheck opts =+    withRepo opts $ \rep -> uncheckClientErrors $ do+      mNow <- if globalCheckExpiry opts+                then Just `fmap` getCurrentTime+                else return Nothing+      print =<< checkForUpdates rep mNow++cmdGet :: GlobalOpts -> PackageIdentifier -> IO ()+cmdGet opts pkgId = do+    cwd <- getCurrentDirectory+    let localFile = cwd </> fragment tarGzName+    withRepo opts $ \rep -> uncheckClientErrors $+      downloadPackage rep pkgId localFile+  where+    tarGzName :: String+    tarGzName = takeFileName $ repoLayoutPkgTarGz hackageRepoLayout pkgId++cmdEnumIndex :: GlobalOpts -> NewOnly -> IO ()+cmdEnumIndex opts False =+    withRepo opts $ \rep -> uncheckClientErrors $ do+      dir <- getDirectory rep+      forM_ (directoryEntries dir) $ putStrLn . aux+  where+    aux :: (Pretty fp, Pretty file) => (DirectoryEntry, fp, Maybe file) -> String+    aux (_, _,  Just file) = pretty file+    aux (_, fp, Nothing  ) = "unrecognized: " ++ pretty fp+cmdEnumIndex opts True = do+    withRepo opts $ \rep -> uncheckClientErrors $ do+      withIndex rep $ \IndexCallbacks{..} -> do+        let go n = do (Some IndexEntry{..}, mNext) <- indexLookupEntry n+                      putStrLn $ pretty indexEntryPath+                      case mNext of+                        Nothing   -> return ()+                        Just next -> go next+        startingPoint <- getStartingPoint (directoryFirst indexDirectory)+        if (startingPoint == directoryNext indexDirectory)+          then putStrLn "No new entries"+          else do+            go startingPoint+            saveStartingPoint $ directoryNext indexDirectory+  where+    getStartingPoint :: DirectoryEntry -> IO DirectoryEntry+    getStartingPoint def =+      catch (read <$> readFile marker)+            (\(SomeException _) -> return def)++    saveStartingPoint :: DirectoryEntry -> IO ()+    saveStartingPoint = writeFile marker . show++    marker :: FilePath+    marker = toFilePath (globalCache opts </> fragment "enum.marker")++cmdGetCabal :: GlobalOpts -> PackageIdentifier -> IO ()+cmdGetCabal opts pkgId =+    withRepo opts $ \rep -> uncheckClientErrors $+      withIndex rep $ \IndexCallbacks{..} ->+        BS.L.putStr . trusted =<< indexLookupCabal pkgId++cmdGetHash :: GlobalOpts -> PackageIdentifier -> IO ()+cmdGetHash opts pkgId =+    withRepo opts $ \rep -> uncheckClientErrors $+      withIndex rep $ \IndexCallbacks{..} ->+        print =<< indexLookupHash pkgId++{-------------------------------------------------------------------------------+  Common functionality+-------------------------------------------------------------------------------}++withRepo :: GlobalOpts+         -> (forall down. DownloadedFile down => Repository down -> IO a)+         -> IO a+withRepo GlobalOpts{..} = \callback ->+    case globalRepo of+      Left  local  -> withLocalRepo  local  callback+      Right remote -> withRemoteRepo remote callback+  where+    withLocalRepo :: Path Absolute -> (Repository Local.LocalFile -> IO a) -> IO a+    withLocalRepo repo =+        Local.withRepository repo+                             cache+                             hackageRepoLayout+                             hackageIndexLayout+                             logTUF++    withRemoteRepo :: URI -> (Repository Remote.RemoteTemp -> IO a) -> IO a+    withRemoteRepo baseURI callback = withClient $ \httpClient ->+        Remote.withRepository httpClient+                              [baseURI]+                              repoOpts+                              cache+                              hackageRepoLayout+                              hackageIndexLayout+                              logTUF+                              callback++    repoOpts :: Remote.RepoOpts+    repoOpts = Remote.defaultRepoOpts++    withClient :: (HttpLib -> IO a) -> IO a+    withClient act =+        case globalHttpClient of+          "HTTP" ->+            HttpLib.HTTP.withClient $ \browser httpLib -> do+              HttpLib.HTTP.setProxy      browser proxyConfig+              HttpLib.HTTP.setOutHandler browser logHTTP+              HttpLib.HTTP.setErrHandler browser logHTTP+              act httpLib+          "curl" ->+            HttpLib.Curl.withClient $ \httpLib ->+              act httpLib+          "http-client" ->+            HttpLib.HttpClient.withClient proxyConfig $ \_manager httpLib ->+              act httpLib+          otherClient ->+            error $ "unsupported HTTP client " ++ show otherClient++    -- use automatic proxy configuration+    proxyConfig :: forall a. ProxyConfig a+    proxyConfig = ProxyConfigAuto++    -- used for log messages from the Hackage.Security code+    logTUF :: LogMessage -> IO ()+    logTUF msg = putStrLn $ "# " ++ pretty msg++    -- used for log messages from the HTTP clients+    logHTTP :: String -> IO ()+    logHTTP = putStrLn++    cache :: Cache.Cache+    cache = Cache.Cache {+        cacheRoot   = globalCache+      , cacheLayout = cabalCacheLayout+      }
+ hackage-security/example-client/src/Prelude.hs view
@@ -0,0 +1,27 @@+-- | Smooth over differences between various ghc versions by making older+-- preludes look like 4.8.0+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+module Prelude (+    module P+#if !MIN_VERSION_base(4,8,0)+  , Applicative(..)+  , Monoid(..)+  , (<$>)+  , (<$)+  , traverse+#endif+  ) where++#if MIN_VERSION_base(4,8,0)+import "base" Prelude as P+#else+#if MIN_VERSION_base(4,6,0)+import "base" Prelude as P+#else+import "base" Prelude as P hiding (catch)+#endif+import Control.Applicative+import Data.Monoid+import Data.Traversable (traverse)+#endif
+ hackage-security/hackage-repo-tool/ChangeLog.md view
@@ -0,0 +1,13 @@+0.1.1+-----+* Update for hackage-security-0.5++0.1.0.1+-------+* Add missing module to other-modules (#100)+* Allow for hackage-security-0.3+* Include ChangeLog.md in sdist (#98)++0.1.0.0+-------+* Initial (beta) release
+ hackage-security/hackage-repo-tool/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-repo-tool/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-repo-tool/hackage-repo-tool.cabal view
@@ -0,0 +1,69 @@+name:                hackage-repo-tool+version:             0.1.1+synopsis:            Utility to manage secure file-based package repositories+description:         This utility can be used to manage secure file-based+                     repositories (creating TUF metadata as well as a Hackage+                     index tarball). Currently it also provides various+                     lower level utilities for creating and signing TUF files.+                     .+                     This is part of the Hackage Security infrastructure.+homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+homepage:            https://github.com/well-typed/hackage-security+bug-reports:         https://github.com/well-typed/hackage-security/issues+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:+  ChangeLog.md++source-repository head+  type: git+  location: https://github.com/well-typed/hackage-security.git++flag use-network-uri+  description: Are we using network-uri?+  manual: False++executable hackage-repo-tool+  main-is:             Main.hs+  other-modules:       Hackage.Security.RepoTool.Options+                       Hackage.Security.RepoTool.Layout+                       Hackage.Security.RepoTool.Layout.Keys+                       Hackage.Security.RepoTool.Paths+                       Hackage.Security.RepoTool.Util.IO+                       Prelude+  build-depends:       base                 >= 4.4  && < 5,+                       Cabal                >= 1.12 && < 1.25,+                       bytestring           >= 0.9  && < 0.11,+                       directory            >= 1.1  && < 1.3,+                       filepath             >= 1.2  && < 1.5,+                       optparse-applicative >= 0.11 && < 0.13,+                       tar                  >= 0.4  && < 0.6,+                       time                 >= 1.2  && < 1.6,+                       unix                 >= 2.5  && < 2.8,+                       zlib                 >= 0.5  && < 0.7,+                       hackage-security     >= 0.5  && < 0.6+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveDataTypeable+                       FlexibleContexts+                       FlexibleInstances+                       NoMonomorphismRestriction+                       ScopedTypeVariables+                       StandaloneDeriving+                       RecordWildCards+  other-extensions:    TemplateHaskell+  ghc-options:         -Wall++  -- see comments in hackage-security.cabal+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6
+ hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Layout.hs view
@@ -0,0 +1,89 @@+-- | Layout of the local repository as managed by this tool+--+-- The local repository follows a RepoLayout exactly, but adds some additional+-- files. In addition, we also manage a directory of keys (although this will+-- eventually need to be replaced with a proper key management system).+module Hackage.Security.RepoTool.Layout (+    -- * Additional paths in the repository+    repoLayoutIndexDir+    -- * Layout-parametrized version of TargetPath+  , TargetPath'(..)+  , prettyTargetPath'+  , applyTargetPath'+    -- * Utility+  , anchorIndexPath+  , anchorRepoPath+  , anchorKeyPath+  , anchorTargetPath'+  ) where++import Distribution.Package++import Hackage.Security.Client+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty++import Hackage.Security.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Paths++{-------------------------------------------------------------------------------+  Additional paths specifically to the kind of repository this tool manages+-------------------------------------------------------------------------------}++-- | Directory containing the unpacked index+--+-- Since the layout of the tarball may not match the layout of the index,+-- we create a local directory with the unpacked contents of the index.+repoLayoutIndexDir :: RepoLayout -> RepoPath+repoLayoutIndexDir _ = rootPath $ fragment "index"++{-------------------------------------------------------------------------------+  TargetPath'+-------------------------------------------------------------------------------}++-- | This is a variation on 'TargetPath' parameterized by layout+data TargetPath' =+    InRep    (RepoLayout  -> RepoPath)+  | InIdx    (IndexLayout -> IndexPath)+  | InRepPkg (RepoLayout  -> PackageIdentifier -> RepoPath)  PackageIdentifier+  | InIdxPkg (IndexLayout -> PackageIdentifier -> IndexPath) PackageIdentifier++prettyTargetPath' :: GlobalOpts -> TargetPath' -> String+prettyTargetPath' opts = pretty . applyTargetPath' opts++-- | Apply the layout+applyTargetPath' :: GlobalOpts -> TargetPath' -> TargetPath+applyTargetPath' GlobalOpts{..} targetPath =+    case targetPath of+      InRep    file       -> TargetPathRepo  $ file globalRepoLayout+      InIdx    file       -> TargetPathIndex $ file globalIndexLayout+      InRepPkg file pkgId -> TargetPathRepo  $ file globalRepoLayout  pkgId+      InIdxPkg file pkgId -> TargetPathIndex $ file globalIndexLayout pkgId++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++-- | Anchor a tarball path to the repo (see 'repoLayoutIndex')+anchorIndexPath :: GlobalOpts -> RepoLoc -> (IndexLayout -> IndexPath) -> Path Absolute+anchorIndexPath opts@GlobalOpts{..} repoLoc file =+        anchorRepoPath opts repoLoc repoLayoutIndexDir+    </> unrootPath (file globalIndexLayout)++anchorRepoPath :: GlobalOpts -> RepoLoc -> (RepoLayout -> RepoPath) -> Path Absolute+anchorRepoPath GlobalOpts{..} (RepoLoc repoLoc) file =+    anchorRepoPathLocally repoLoc $ file globalRepoLayout++anchorKeyPath :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> Path Absolute+anchorKeyPath GlobalOpts{..} (KeysLoc keysLoc) dir =+    keysLoc </> unrootPath (dir globalKeysLayout)++anchorTargetPath' :: GlobalOpts -> RepoLoc -> TargetPath' -> Path Absolute+anchorTargetPath' opts repoLoc = go+  where+    go :: TargetPath' -> Path Absolute+    go (InRep    file)       = anchorRepoPath  opts repoLoc file+    go (InIdx    file)       = anchorIndexPath opts repoLoc file+    go (InRepPkg file pkgId) = anchorRepoPath  opts repoLoc (`file` pkgId)+    go (InIdxPkg file pkgId) = anchorIndexPath opts repoLoc (`file` pkgId)
+ hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Layout/Keys.hs view
@@ -0,0 +1,44 @@+-- | Layout of the directory containing the (private) keys+module Hackage.Security.RepoTool.Layout.Keys (+    -- * Layout of the keys directory+    KeysLayout(..)+  , defaultKeysLayout+  , keysLayoutKey+  ) where++import Hackage.Security.Client+import Hackage.Security.Util.Path+import Hackage.Security.Util.Some++import Hackage.Security.RepoTool.Paths++-- | Layout of the keys directory+--+-- Specifies the directories containing the keys (relative to the keys loc),+-- as well as the filename for individual keys.+data KeysLayout = KeysLayout {+      keysLayoutRoot      :: KeyPath+    , keysLayoutTarget    :: KeyPath+    , keysLayoutTimestamp :: KeyPath+    , keysLayoutSnapshot  :: KeyPath+    , keysLayoutMirrors   :: KeyPath+    , keysLayoutKeyFile   :: Some Key -> Path Unrooted+    }++defaultKeysLayout :: KeysLayout+defaultKeysLayout = KeysLayout {+      keysLayoutRoot      = rp $ fragment "root"+    , keysLayoutTarget    = rp $ fragment "target"+    , keysLayoutTimestamp = rp $ fragment "timestamp"+    , keysLayoutSnapshot  = rp $ fragment "snapshot"+    , keysLayoutMirrors   = rp $ fragment "mirrors"+    , keysLayoutKeyFile   = \key -> let kId = keyIdString (someKeyId key)+                                    in fragment kId <.> "private"+    }+  where+    rp :: Path Unrooted -> KeyPath+    rp = rootPath++keysLayoutKey :: (KeysLayout -> KeyPath) -> Some Key -> KeysLayout -> KeyPath+keysLayoutKey dir key keysLayout@KeysLayout{..} =+   dir keysLayout </> keysLayoutKeyFile key
+ hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Options.hs view
@@ -0,0 +1,198 @@+module Hackage.Security.RepoTool.Options (+    GlobalOpts(..)+  , Command(..)+  , KeyLoc+  , DeleteExistingSignatures+  , getOptions+  ) where++import Network.URI (URI, parseURI)+import Options.Applicative+import System.IO.Unsafe (unsafePerformIO)++import Hackage.Security.Client+import Hackage.Security.Util.Path++import Hackage.Security.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Paths++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++-- | Command line options+data GlobalOpts = GlobalOpts {+    -- | Key directory layout+    globalKeysLayout :: KeysLayout++    -- | Local repository layout+  , globalRepoLayout :: RepoLayout++    -- | Local index layout+  , globalIndexLayout :: IndexLayout++    -- | Should we be verbose?+  , globalVerbose :: Bool++    -- | Expiry time when creating root (in years)+  , globalExpireRoot :: Integer++    -- | Expiry time when creating mirrors (in years)+  , globalExpireMirrors :: Integer++    -- | Command to execute+  , globalCommand :: Command+  }++data Command =+    -- | Create keys+    CreateKeys KeysLoc++    -- | Bootstrap a secure local repository+  | Bootstrap KeysLoc RepoLoc++    -- | Update a previously bootstrapped local repository+  | Update KeysLoc RepoLoc++    -- | Create root metadta+  | CreateRoot KeysLoc (Path Absolute)++    -- | Create mirrors metadata+  | CreateMirrors KeysLoc (Path Absolute) [URI]++    -- | Create a directory with symlinks in cabal-local-rep layout+  | SymlinkCabalLocalRepo RepoLoc RepoLoc++    -- | Sign an individual file+  | Sign [KeyLoc] DeleteExistingSignatures (Path Absolute)++type KeyLoc                   = Path Absolute+type DeleteExistingSignatures = Bool++{-------------------------------------------------------------------------------+  Parsers+-------------------------------------------------------------------------------}++getOptions :: IO GlobalOpts+getOptions = execParser opts+  where+    opts = info (helper <*> parseGlobalOptions) $ mconcat [+        fullDesc+      , header "Manage local Hackage repositories"+      ]++parseRepoLoc :: Parser RepoLoc+parseRepoLoc = RepoLoc <$> (option (str >>= readAbsolutePath) $ mconcat [+      long "repo"+    , metavar "PATH"+    , help "Path to local repository"+    ])++parseKeysLoc :: Parser KeysLoc+parseKeysLoc = KeysLoc <$> (option (str >>= readAbsolutePath) $ mconcat [+      long "keys"+    , metavar "PATH"+    , help "Path to key store"+    ])++parseCreateKeys :: Parser Command+parseCreateKeys = CreateKeys <$> parseKeysLoc++parseBootstrap :: Parser Command+parseBootstrap = Bootstrap <$> parseKeysLoc <*> parseRepoLoc++parseUpdate :: Parser Command+parseUpdate = Update <$> parseKeysLoc <*> parseRepoLoc++parseCreateRoot :: Parser Command+parseCreateRoot = CreateRoot+  <$> parseKeysLoc+  <*> (option (str >>= readAbsolutePath) $ mconcat [+          short 'o'+        , metavar "FILE"+        , help "Location of the root file"+        ])++parseCreateMirrors :: Parser Command+parseCreateMirrors = CreateMirrors+  <$> parseKeysLoc+  <*> (option (str >>= readAbsolutePath) $ mconcat [+          short 'o'+        , metavar "FILE"+        , help "Location of the mirrors file"+        ])+  <*> (many $ argument (str >>= readURI) (metavar "MIRROR"))++parseSymlinkCabalLocalRepo :: Parser Command+parseSymlinkCabalLocalRepo = SymlinkCabalLocalRepo+  <$> parseRepoLoc+  <*> (option (str >>= liftA RepoLoc . readAbsolutePath) $ mconcat [+          long "cabal-repo"+        , help "Location of the cabal repo"+        ])++parseSign :: Parser Command+parseSign = Sign+  <$> (many . option (str >>= readAbsolutePath) $ mconcat [+         long "key"+       , help "Path to private key (can be specified multiple times)"+       ])+  <*> (switch $ mconcat [+         long "delete-existing"+       , help "Delete any existing signatures"+       ])+  <*> argument (str >>= readAbsolutePath) (metavar "FILE")++-- | Global options+--+-- TODO: Make repo and keys layout configurable+parseGlobalOptions :: Parser GlobalOpts+parseGlobalOptions = GlobalOpts+  <$> (pure defaultKeysLayout)+  <*> (pure hackageRepoLayout)+  <*> (pure hackageIndexLayout)+  <*> (switch $ mconcat [+          long "verbose"+        , short 'v'+        , help "Verbose logging"+        ])+  <*> (option auto $ mconcat [+          long "expire-root"+        , metavar "YEARS"+        , help "Expiry time for the root info"+        , value 1+        , showDefault+        ])+  <*> (option auto $ mconcat [+          long "expire-mirrors"+        , metavar "YEARS"+        , help "Expiry time for the mirrors"+        , value 10+        , showDefault+        ])+  <*> (subparser $ mconcat [+          command "create-keys" $ info (helper <*> parseCreateKeys) $+            progDesc "Create keys"+        , command "bootstrap" $ info (helper <*> parseBootstrap) $+            progDesc "Bootstrap a local repository"+        , command "update" $ info (helper <*> parseUpdate) $+            progDesc "Update a (previously bootstrapped) local repository"+        , command "create-root" $ info (helper <*> parseCreateRoot) $+            progDesc "Create root metadata"+        , command "create-mirrors" $ info (helper <*> parseCreateMirrors) $+            progDesc "Create mirrors metadata. All MIRRORs specified on the command line will be written to the file."+        , command "symlink-cabal-local-repo" $ info (helper <*> parseSymlinkCabalLocalRepo) $+            progDesc "Create a directory in cabal-local-repo layout with symlinks to the specified repository."+        , command "sign" $ info (helper <*> parseSign) $+            progDesc "Sign a file"+        ])++readURI :: String -> ReadM URI+readURI uriStr =+   case parseURI uriStr of+     Nothing  -> fail $ "Invalid URI " ++ show uriStr+     Just uri -> return uri++-- Sadly, cannot do I/O actions inside ReadM+readAbsolutePath :: String -> ReadM (Path Absolute)+readAbsolutePath = return . unsafePerformIO . makeAbsolute . fromFilePath
+ hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Paths.hs view
@@ -0,0 +1,33 @@+-- | Additional paths+module Hackage.Security.RepoTool.Paths (+    -- * Repo+    RepoLoc(..)+    -- * Keys+  , KeyRoot+  , KeyPath+  , KeysLoc(..)+  ) where++import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty++{-------------------------------------------------------------------------------+  Repo+-------------------------------------------------------------------------------}++newtype RepoLoc = RepoLoc { repoLocPath :: Path Absolute }+  deriving Eq++{-------------------------------------------------------------------------------+  Keys+-------------------------------------------------------------------------------}++-- | The key directory+data KeyRoot+type KeyPath = Path KeyRoot++instance Pretty (Path KeyRoot) where+    pretty (Path fp) = "<keys>/" ++ fp++newtype KeysLoc = KeysLoc { keysLocPath :: Path Absolute }+  deriving Eq
+ hackage-security/hackage-repo-tool/src/Hackage/Security/RepoTool/Util/IO.hs view
@@ -0,0 +1,112 @@+-- | IO utilities+{-# LANGUAGE CPP #-}+module Hackage.Security.RepoTool.Util.IO (+    -- * Miscellaneous+    compress+  , getFileModTime+  , createSymbolicLink+    -- * Tar archives+  , TarGzError+  , tarExtractFile+  ) where++import Control.Exception+import Data.Typeable+import System.IO.Error+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip  as GZip+import qualified Data.ByteString.Lazy    as BS.L++-- Unlike the hackage-security library properly,+-- this currently works on unix systems only+import System.Posix.Types (EpochTime)+import qualified System.Posix.Files as Posix++-- hackage-security+import Hackage.Security.Util.Path++-- hackage-repo-tool+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Layout+import Hackage.Security.RepoTool.Paths++-- | Get the modification time of the specified file+--+-- Returns 0 if the file does not exist .+getFileModTime :: GlobalOpts -> RepoLoc -> TargetPath' -> IO EpochTime+getFileModTime opts repoLoc targetPath =+    handle handler $+      Posix.modificationTime <$> Posix.getFileStatus (toFilePath fp)+  where+    fp :: Path Absolute+    fp = anchorTargetPath' opts repoLoc targetPath++    handler :: IOException -> IO EpochTime+    handler ex = if isDoesNotExistError ex then return 0+                                           else throwIO ex++compress :: Path Absolute -> Path Absolute -> IO ()+compress src dst =+    withFile dst WriteMode $ \h ->+      BS.L.hPut h =<< GZip.compress <$> readLazyByteString src++-- | Create a symbolic link (unix only)+--+-- Create the directory for the target if it does not exist.+--+-- TODO: Currently this always creates links to absolute locations, whether the+-- user specified an absolute or a relative target.+createSymbolicLink :: (FsRoot root, FsRoot root')+                   => Path root  -- ^ Link target+                   -> Path root' -- ^ Link location+                   -> IO ()+createSymbolicLink linkTarget linkLoc = do+    createDirectoryIfMissing True (takeDirectory linkLoc)+    linkTarget' <- toAbsoluteFilePath linkTarget+    linkLoc'    <- toAbsoluteFilePath linkLoc+    Posix.createSymbolicLink linkTarget' linkLoc'++{-------------------------------------------------------------------------------+  Working with tar archives+-------------------------------------------------------------------------------}++-- | Extract a file from a tar archive+--+-- Throws an exception if there is an error in the archive or when the entry+-- is not a file. Returns nothing if the entry cannot be found.+tarExtractFile :: GlobalOpts+               -> RepoLoc+               -> TargetPath'+               -> FilePath+               -> IO (Maybe (BS.L.ByteString, Tar.FileSize))+tarExtractFile opts repoLoc pathTarGz pathToExtract =+     handle (throwIO . TarGzError (prettyTargetPath' opts pathTarGz)) $ do+       let pathTarGz' = anchorTargetPath' opts repoLoc pathTarGz+       go =<< Tar.read . GZip.decompress <$> readLazyByteString pathTarGz'+  where+    go :: Exception e => Tar.Entries e -> IO (Maybe (BS.L.ByteString, Tar.FileSize))+    go Tar.Done        = return Nothing+    go (Tar.Fail err)  = throwIO err+    go (Tar.Next e es) =+      if Tar.entryPath e == pathToExtract+        then case Tar.entryContent e of+               Tar.NormalFile bs sz -> return $ Just (bs, sz)+               _ -> throwIO $ userError+                            $ "tarExtractFile: "+                           ++ pathToExtract ++ " not a normal file"+        else do -- putStrLn $ show (Tar.entryPath e) ++ " /= " ++ show path+                go es++data TarGzError = TarGzError FilePath SomeException+  deriving (Typeable)++instance Exception TarGzError where+#if MIN_VERSION_base(4,8,0)+  displayException (TarGzError path e) = path ++ ": " ++ displayException e++deriving instance Show TarGzError+#else+instance Show TarGzError where+  show (TarGzError path e) = path ++ ": " ++ show e+#endif
+ hackage-security/hackage-repo-tool/src/Main.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Control.Exception+import Control.Monad+import Data.List (nub)+import Data.Maybe (catMaybes, mapMaybe)+import Data.Time+import GHC.Conc.Sync (setUncaughtExceptionHandler)+import Network.URI (URI)+import System.Exit+import System.IO.Error (isAlreadyExistsError)+import qualified Data.ByteString.Lazy as BS.L+import qualified System.FilePath      as FilePath++-- Cabal+import Distribution.Package+import Distribution.Text++-- hackage-security+import Hackage.Security.Server+import Hackage.Security.Util.Some+import Hackage.Security.Util.IO+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Key.Env     as KeyEnv+import qualified Hackage.Security.TUF.FileMap as FileMap+import qualified Hackage.Security.Util.Lens   as Lens+import Text.JSON.Canonical (JSValue)++-- hackage-repo-tool+import Hackage.Security.RepoTool.Options+import Hackage.Security.RepoTool.Layout+import Hackage.Security.RepoTool.Layout.Keys+import Hackage.Security.RepoTool.Paths+import Hackage.Security.RepoTool.Util.IO++{-------------------------------------------------------------------------------+  Main application driver+-------------------------------------------------------------------------------}++main :: IO ()+main = do+    setUncaughtExceptionHandler topLevelExceptionHandler+    opts@GlobalOpts{..} <- getOptions+    case globalCommand of+      CreateKeys keysLoc ->+        createKeys opts keysLoc+      Bootstrap keysLoc repoLoc ->+        bootstrapOrUpdate opts keysLoc repoLoc True+      Update keysLoc repoLoc ->+        bootstrapOrUpdate opts keysLoc repoLoc False+      CreateRoot keysLoc rootLoc ->+        createRoot opts keysLoc rootLoc+      CreateMirrors keysLoc mirrorsLoc mirrors ->+        createMirrors opts keysLoc mirrorsLoc mirrors+      SymlinkCabalLocalRepo repoLoc cabalRepoLoc ->+        symlinkCabalLocalRepo opts repoLoc cabalRepoLoc+      Sign keys deleteExisting file ->+        signFile keys deleteExisting file++-- | Top-level exception handler that uses 'displayException'+--+-- Although base 4.8 introduces 'displayException', the top-level exception+-- handler still uses 'show', sadly. See "PROPOSAL: Add displayException to+-- Exception typeclass" thread on the libraries mailing list.+--+-- NOTE: This is a terrible hack. See the above thread for some insights into+-- how we should do this better. For now it will do however.+topLevelExceptionHandler :: SomeException -> IO ()+topLevelExceptionHandler e = do+    putStrLn $ displayException e+    exitFailure++#if !MIN_VERSION_base(4,8,0)+displayException :: Exception e => e -> String+displayException = show+#endif++{-------------------------------------------------------------------------------+  Creating keys+-------------------------------------------------------------------------------}++createKeys :: GlobalOpts -> KeysLoc -> IO ()+createKeys opts keysLoc = do+    privateRoot      <- replicateM 3 $ createKey' KeyTypeEd25519+    privateTarget    <- replicateM 3 $ createKey' KeyTypeEd25519+    privateTimestamp <- replicateM 1 $ createKey' KeyTypeEd25519+    privateSnapshot  <- replicateM 1 $ createKey' KeyTypeEd25519+    privateMirrors   <- replicateM 3 $ createKey' KeyTypeEd25519+    writeKeys opts keysLoc PrivateKeys{..}++{-------------------------------------------------------------------------------+  Dealing with (private) keys+-------------------------------------------------------------------------------}++data PrivateKeys = PrivateKeys {+    privateRoot      :: [Some Key]+  , privateTarget    :: [Some Key]+  , privateTimestamp :: [Some Key]+  , privateSnapshot  :: [Some Key]+  , privateMirrors   :: [Some Key]+  }++readKeys :: GlobalOpts -> KeysLoc -> IO PrivateKeys+readKeys opts keysLoc =+    PrivateKeys <$> readKeysAt opts keysLoc keysLayoutRoot+                <*> readKeysAt opts keysLoc keysLayoutTarget+                <*> readKeysAt opts keysLoc keysLayoutTimestamp+                <*> readKeysAt opts keysLoc keysLayoutSnapshot+                <*> readKeysAt opts keysLoc keysLayoutMirrors++writeKeys :: GlobalOpts -> KeysLoc -> PrivateKeys -> IO ()+writeKeys opts keysLoc PrivateKeys{..} = do+    forM_ privateRoot      $ writeKey opts keysLoc keysLayoutRoot+    forM_ privateTarget    $ writeKey opts keysLoc keysLayoutTarget+    forM_ privateTimestamp $ writeKey opts keysLoc keysLayoutTimestamp+    forM_ privateSnapshot  $ writeKey opts keysLoc keysLayoutSnapshot+    forM_ privateMirrors   $ writeKey opts keysLoc keysLayoutMirrors++readKeysAt :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> IO [Some Key]+readKeysAt opts keysLoc subDir = catMaybes <$> do+    entries <- getDirectoryContents absPath+    forM entries $ \entry -> do+      let path = absPath </> entry+      mKey <- readJSON_NoKeys_NoLayout path+      case mKey of+        Left _err -> do logWarn opts $ "Skipping unrecognized " ++ pretty path+                        return Nothing+        Right key -> return $ Just key+  where+    absPath = anchorKeyPath opts keysLoc subDir++writeKey :: GlobalOpts -> KeysLoc -> (KeysLayout -> KeyPath) -> Some Key -> IO ()+writeKey opts@GlobalOpts{..} keysLoc subDir key = do+    logInfo opts $ "Writing " ++ pretty (relPath globalKeysLayout)+    createDirectoryIfMissing True (takeDirectory absPath)+    writeJSON_NoLayout absPath key+  where+    relPath = keysLayoutKey subDir key+    absPath = anchorKeyPath opts keysLoc relPath++{-------------------------------------------------------------------------------+  Creating individual files++  We translate absolute paths to repo layout to fit with rest of infrastructure.+-------------------------------------------------------------------------------}++createRoot :: GlobalOpts -> KeysLoc -> Path Absolute -> IO ()+createRoot opts@GlobalOpts{..} keysLoc rootLoc = do+    keys <- readKeys opts keysLoc+    now  <- getCurrentTime+    updateRoot opts { globalRepoLayout = layout }+               repoLoc+               WriteUpdate+               keys+               now+  where+    repoLoc = RepoLoc $ takeDirectory rootLoc+    layout  = globalRepoLayout {+                  repoLayoutRoot = rootFragment $ takeFileName rootLoc+                }++createMirrors :: GlobalOpts -> KeysLoc -> Path Absolute -> [URI] -> IO ()+createMirrors opts@GlobalOpts{..} keysLoc mirrorsLoc mirrors = do+    keys <- readKeys opts keysLoc+    now  <- getCurrentTime+    updateMirrors opts { globalRepoLayout = layout }+                  repoLoc+                  WriteUpdate+                  keys+                  now+                  mirrors+  where+    repoLoc = RepoLoc $ takeDirectory mirrorsLoc+    layout  = globalRepoLayout {+                  repoLayoutMirrors = rootFragment $ takeFileName mirrorsLoc+                }++rootFragment :: String -> RepoPath+rootFragment = rootPath . fragment++{-------------------------------------------------------------------------------+  Bootstrapping / updating++  TODO: Some of this functionality should be moved to+  @Hackage.Security.Server.*@ (to be shared by both, say, Hackage, and+  secure-local),  but I'm not sure precisely in what form yet.+-------------------------------------------------------------------------------}++bootstrapOrUpdate :: GlobalOpts -> KeysLoc -> RepoLoc -> Bool -> IO ()+bootstrapOrUpdate opts@GlobalOpts{..} keysLoc repoLoc isBootstrap = do+    -- Collect info+    keys <- readKeys opts keysLoc+    now  <- getCurrentTime+    pkgs <- findPackages opts repoLoc++    -- Sanity check+    repoLayoutOk <- checkRepoLayout opts repoLoc pkgs+    unless repoLayoutOk $+      throwIO $ userError "Unexpected repository layout"++    -- We overwrite files during bootstrap process, but update them only+    -- if necessary during an update. Note that we _only_ write the updated+    -- files to the tarball, so the user deletes the tarball and then calls+    -- update (rather than bootstrap) the tarball will be missing files.+    let whenWrite = if isBootstrap+                      then WriteInitial+                      else WriteUpdate++    -- If doing bootstrap: create root and mirrors+    when isBootstrap $ do+      updateRoot    opts repoLoc whenWrite keys now+      updateMirrors opts repoLoc whenWrite keys now []++    -- Create targets.json for each package version+    forM_ pkgs $ \pkgId -> do+      createPackageMetadata opts repoLoc whenWrite pkgId+      extractCabalFile      opts repoLoc whenWrite pkgId++    -- Recreate index tarball+    newFiles <- findNewIndexFiles opts repoLoc whenWrite+    case (whenWrite, null newFiles) of+      (WriteInitial, _) -> do+        -- If we are recreating all files, also recreate the index+        _didExist <- handleDoesNotExist $ removeFile pathIndexTar+        logInfo opts $ "Writing " ++ prettyRepo repoLayoutIndexTar+      (WriteUpdate, True) -> do+        logInfo opts $ "Skipping " ++ prettyRepo repoLayoutIndexTar+      (WriteUpdate, False) ->+        logInfo opts $ "Appending " ++ show (length newFiles)+                    ++ " file(s) to " ++ prettyRepo repoLayoutIndexTar+    unless (null newFiles) $ do+      tarAppend+        (anchorRepoPath opts repoLoc repoLayoutIndexTar)+        (anchorRepoPath opts repoLoc repoLayoutIndexDir)+        (map castRoot newFiles)++      logInfo opts $ "Writing " ++ prettyRepo repoLayoutIndexTarGz+      compress (anchorRepoPath opts repoLoc repoLayoutIndexTar)+               (anchorRepoPath opts repoLoc repoLayoutIndexTarGz)++    -- Create snapshot+    -- TODO: If we are updating we should be incrementing the version, not+    -- keeping it the same+    rootInfo    <- computeFileInfo' repoLayoutRoot+    mirrorsInfo <- computeFileInfo' repoLayoutMirrors+    tarInfo     <- computeFileInfo' repoLayoutIndexTar+    tarGzInfo   <- computeFileInfo' repoLayoutIndexTarGz+    let snapshot = Snapshot {+            snapshotVersion     = versionInitial+          , snapshotExpires     = expiresInDays now 3+          , snapshotInfoRoot    = rootInfo+          , snapshotInfoMirrors = mirrorsInfo+          , snapshotInfoTar     = Just tarInfo+          , snapshotInfoTarGz   = tarGzInfo+          }+    updateFile opts+               repoLoc+               whenWrite+               (InRep repoLayoutSnapshot)+               (withSignatures globalRepoLayout (privateSnapshot keys))+               snapshot++    -- Finally, create the timestamp+    snapshotInfo <- computeFileInfo' repoLayoutSnapshot+    let timestamp = Timestamp {+            timestampVersion      = versionInitial+          , timestampExpires      = expiresInDays now 3+          , timestampInfoSnapshot = snapshotInfo+          }+    updateFile opts+               repoLoc+               whenWrite+               (InRep repoLayoutTimestamp)+               (withSignatures globalRepoLayout (privateTimestamp keys))+               timestamp+  where+    pathIndexTar :: Path Absolute+    pathIndexTar = anchorRepoPath opts repoLoc repoLayoutIndexTar++    -- | Compute file information for a file in the repo+    computeFileInfo' :: (RepoLayout -> RepoPath) -> IO FileInfo+    computeFileInfo' = computeFileInfo . anchorRepoPath opts repoLoc++    prettyRepo :: (RepoLayout -> RepoPath) -> String+    prettyRepo = prettyTargetPath' opts . InRep++-- | Create root metadata+updateRoot :: GlobalOpts+           -> RepoLoc+           -> WhenWrite+           -> PrivateKeys+           -> UTCTime+           -> IO ()+updateRoot opts repoLoc whenWrite keys now =+    updateFile opts+               repoLoc+               whenWrite+               (InRep repoLayoutRoot)+               (withSignatures' (privateRoot keys))+               root+  where+    root :: Root+    root = Root {+        rootVersion = versionInitial+      , rootExpires = expiresInDays now (globalExpireRoot opts * 365)+      , rootKeys    = KeyEnv.fromKeys $ concat [+                          privateRoot      keys+                        , privateTarget    keys+                        , privateSnapshot  keys+                        , privateTimestamp keys+                        , privateMirrors   keys+                        ]+      , rootRoles   = RootRoles {+            rootRolesRoot = RoleSpec {+                roleSpecKeys      = map somePublicKey (privateRoot keys)+              , roleSpecThreshold = KeyThreshold 2+              }+          , rootRolesTargets = RoleSpec {+                roleSpecKeys      = map somePublicKey (privateTarget keys)+              , roleSpecThreshold = KeyThreshold 1+              }+          , rootRolesSnapshot = RoleSpec {+                roleSpecKeys      = map somePublicKey (privateSnapshot keys)+              , roleSpecThreshold = KeyThreshold 1+              }+          , rootRolesTimestamp = RoleSpec {+                roleSpecKeys      = map somePublicKey (privateTimestamp keys)+              , roleSpecThreshold = KeyThreshold 1+              }+          , rootRolesMirrors = RoleSpec {+                roleSpecKeys      = map somePublicKey (privateMirrors keys)+              , roleSpecThreshold = KeyThreshold 1+              }+          }+      }++-- | Create root metadata+updateMirrors :: GlobalOpts+              -> RepoLoc+              -> WhenWrite+              -> PrivateKeys+              -> UTCTime+              -> [URI]+              -> IO ()+updateMirrors opts repoLoc whenWrite keys now uris =+    updateFile opts+               repoLoc+               whenWrite+               (InRep repoLayoutMirrors)+               (withSignatures' (privateMirrors keys))+               mirrors+  where+    mirrors :: Mirrors+    mirrors = Mirrors {+        mirrorsVersion = versionInitial+      , mirrorsExpires = expiresInDays now (globalExpireMirrors opts * 365)+      , mirrorsMirrors = map mkMirror uris+      }++    mkMirror :: URI -> Mirror+    mkMirror uri = Mirror uri MirrorFull++-- | Create package metadata+createPackageMetadata :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()+createPackageMetadata opts repoLoc whenWrite pkgId = do+    srcTS <- getFileModTime opts repoLoc src+    dstTS <- getFileModTime opts repoLoc dst+    let skip = case whenWrite of+                 WriteInitial -> False+                 WriteUpdate  -> dstTS >= srcTS++    if skip+      then logInfo opts $ "Skipping " ++ prettyTargetPath' opts dst+      else do+        fileMapEntries <- mapM computeFileMapEntry fileMapFiles+        let targets = Targets {+                targetsVersion     = versionInitial+              , targetsExpires     = expiresNever+              , targetsTargets     = FileMap.fromList fileMapEntries+              , targetsDelegations = Nothing+              }++        -- Currently we "sign" with no keys+        updateFile opts+                   repoLoc+                   whenWrite+                   dst+                   (withSignatures' [])+                   targets+  where+    computeFileMapEntry :: TargetPath' -> IO (TargetPath, FileInfo)+    computeFileMapEntry file = do+      info <- computeFileInfo $ anchorTargetPath' opts repoLoc file+      return (applyTargetPath' opts file, info)++    -- The files we need to add to the package targets file+    -- Currently this is just the .tar.gz file+    fileMapFiles :: [TargetPath']+    fileMapFiles = [src]++    src, dst :: TargetPath'+    src = InRepPkg repoLayoutPkgTarGz     pkgId+    dst = InIdxPkg indexLayoutPkgMetadata pkgId++{-------------------------------------------------------------------------------+  Working with the index+-------------------------------------------------------------------------------}++-- | Find the files we need to add to the index+findNewIndexFiles :: GlobalOpts -> RepoLoc -> WhenWrite -> IO [IndexPath]+findNewIndexFiles opts@GlobalOpts{..} repoLoc whenWrite = do+    indexTS    <- getFileModTime opts repoLoc (InRep repoLayoutIndexTar)+    indexFiles <- getRecursiveContents absIndexDir++    let indexFiles' :: [IndexPath]+        indexFiles' = map rootPath indexFiles++    case whenWrite of+      WriteInitial -> return indexFiles'+      WriteUpdate  -> liftM catMaybes $+        forM indexFiles' $ \indexFile -> do+          fileTS <- getFileModTime opts repoLoc $ InIdx (const indexFile)+          if fileTS > indexTS then return $ Just indexFile+                              else return Nothing+  where+    absIndexDir :: Path Absolute+    absIndexDir = anchorRepoPath opts repoLoc repoLayoutIndexDir++-- | Extract the cabal file from the package tarball and copy it to the index+extractCabalFile :: GlobalOpts -> RepoLoc -> WhenWrite -> PackageIdentifier -> IO ()+extractCabalFile opts@GlobalOpts{..} repoLoc whenWrite pkgId = do+    srcTS <- getFileModTime opts repoLoc src+    dstTS <- getFileModTime opts repoLoc dst+    let skip = case whenWrite of+                 WriteInitial -> False+                 WriteUpdate  -> dstTS >= srcTS+    if skip+      then logInfo opts $ "Skipping " ++ prettyTargetPath' opts dst+      else do+        mCabalFile <- try $ tarExtractFile opts repoLoc src pathCabalInTar+        case mCabalFile of+          Left (ex :: SomeException) ->+            logWarn opts $ "Failed to extract .cabal from package " ++ display pkgId+                        ++ ": " ++ displayException ex+          Right Nothing ->+            logWarn opts $ ".cabal file missing for package " ++ display pkgId+          Right (Just (cabalFile, _cabalSize)) -> do+            logInfo opts $ "Writing "+                        ++ prettyTargetPath' opts dst+                        ++ " (extracted from "+                        ++ prettyTargetPath' opts src+                        ++ ")"+            withFile pathCabalInIdx WriteMode $ \h -> BS.L.hPut h cabalFile+  where+    pathCabalInTar :: FilePath+    pathCabalInTar = FilePath.joinPath [+                         display pkgId+                       , display (packageName pkgId)+                       ] FilePath.<.> "cabal"++    pathCabalInIdx :: Path Absolute+    pathCabalInIdx = anchorTargetPath' opts repoLoc dst++    src, dst :: TargetPath'+    dst = InIdxPkg indexLayoutPkgCabal pkgId+    src = InRepPkg repoLayoutPkgTarGz  pkgId++{-------------------------------------------------------------------------------+  Updating files in the repo or in the index+-------------------------------------------------------------------------------}++data WhenWrite =+    -- | Write the initial version of a file+    --+    -- If applicable, set file version to 1.+    WriteInitial++    -- | Update an existing+    --+    -- If applicable, increment file version number.+  | WriteUpdate++-- | Write canonical JSON+--+-- We write the file to a temporary location and compare file info with the file+-- that was already in the target location (if any). If it's the same (modulo+-- version number) we don't overwrite it and return Nothing; otherwise we+-- increment the version number, write the file, and (if it's in the index)+-- copy it to the unpacked index directory.+updateFile :: forall a. (ToJSON WriteJSON (Signed a), HasHeader a)+           => GlobalOpts+           -> RepoLoc+           -> WhenWrite+           -> TargetPath'+           -> (a -> Signed a)          -- ^ Signing function+           -> a                        -- ^ Unsigned file contents+           -> IO ()+updateFile opts@GlobalOpts{..} repoLoc whenWrite fileLoc signPayload a = do+    mOldHeader :: Maybe (Either DeserializationError (UninterpretedSignatures Header)) <-+      handleDoesNotExist $ readJSON_NoKeys_NoLayout fp++    case (whenWrite, mOldHeader) of+      (WriteInitial, _) ->+        writeDoc writing a+      (WriteUpdate, Nothing) -> -- no previous version+        writeDoc creating a+      (WriteUpdate, Just (Left _err)) -> -- old file corrupted+        writeDoc overwriting a+      (WriteUpdate, Just (Right (UninterpretedSignatures oldHeader _oldSigs))) -> do+        -- We cannot quite read the entire old file, because we don't know what+        -- key environment to use. Instead, we render the _new_ file, but+        -- setting the version number to be equal to the version number of the+        -- old file. If the result turns out to be equal to the old file (same+        -- FileInfo), we skip writing this file. However, if this is NOT equal,+        -- we set the version number of the new file to be equal to the version+        -- number of the old plus one, and write it.+        oldFileInfo <- computeFileInfo fp++        let oldVersion :: FileVersion+            oldVersion = headerVersion oldHeader++            wOldVersion, wIncVersion :: a+            wOldVersion = Lens.set fileVersion oldVersion a+            wIncVersion = Lens.set fileVersion (versionIncrement oldVersion) a++            wOldSigned :: Signed a+            wOldSigned = signPayload wOldVersion++            wOldRendered :: BS.L.ByteString+            wOldRendered = renderJSON globalRepoLayout wOldSigned++            -- TODO: We could be be more efficient here and verify file size+            -- first; however, these files are tiny so it doesn't really matter.+            wOldFileInfo :: FileInfo+            wOldFileInfo = fileInfo wOldRendered++        if knownFileInfoEqual oldFileInfo wOldFileInfo+          then logInfo opts $ "Unchanged " ++ prettyTargetPath' opts fileLoc+          else writeDoc updating wIncVersion+  where+    -- | Actually write the file+    writeDoc :: String -> a -> IO ()+    writeDoc reason doc = do+      logInfo opts reason+      createDirectoryIfMissing True (takeDirectory fp)+      writeJSON globalRepoLayout fp (signPayload doc)++    fp :: Path Absolute+    fp = anchorTargetPath' opts repoLoc fileLoc++    writing, creating, overwriting, updating :: String+    writing     = "Writing "     ++ prettyTargetPath' opts fileLoc+    creating    = "Creating "    ++ prettyTargetPath' opts fileLoc+    overwriting = "Overwriting " ++ prettyTargetPath' opts fileLoc ++ " (old file corrupted)"+    updating    = "Updating "    ++ prettyTargetPath' opts fileLoc++{-------------------------------------------------------------------------------+  Inspect the repo layout+-------------------------------------------------------------------------------}++-- | Find packages+--+-- Repository layouts are configurable, but we don't know if the layout of the+-- current directory matches the specified layout. We therefore here just search+-- through the directory looking for anything that looks like a package.+-- We can then verify that this list of packages actually matches the layout as+-- a separate step.+findPackages :: GlobalOpts -> RepoLoc -> IO [PackageIdentifier]+findPackages GlobalOpts{..} (RepoLoc repoLoc) =+    nub . mapMaybe isPackage <$> getRecursiveContents repoLoc+  where+    isPackage :: Path Unrooted -> Maybe PackageIdentifier+    isPackage path = do+      guard $ not (isIndex path)+      pkg <- hasExtensions path [".tar", ".gz"]+      simpleParse pkg++    isIndex :: Path Unrooted -> Bool+    isIndex = (==) (unrootPath (repoLayoutIndexTarGz globalRepoLayout))++-- | Check that packages are in their expected location+checkRepoLayout :: GlobalOpts -> RepoLoc -> [PackageIdentifier] -> IO Bool+checkRepoLayout opts repoLoc = liftM and . mapM checkPackage+  where+    checkPackage :: PackageIdentifier -> IO Bool+    checkPackage pkgId = do+        existsTarGz <- doesFileExist $ anchorTargetPath' opts repoLoc expectedTarGz+        unless existsTarGz $+          logWarn opts $ "Package tarball " ++ display pkgId+                      ++ " expected in location "+                      ++ prettyTargetPath' opts expectedTarGz++        return existsTarGz+      where+        expectedTarGz :: TargetPath'+        expectedTarGz = InRepPkg repoLayoutPkgTarGz pkgId++{-------------------------------------------------------------------------------+  Creating Cabal-local-repo+-------------------------------------------------------------------------------}++symlinkCabalLocalRepo :: GlobalOpts -> RepoLoc -> RepoLoc -> IO ()+symlinkCabalLocalRepo opts@GlobalOpts{..} repoLoc cabalRepoLoc = do+    symlink repoLayoutIndexTar+    pkgs <- findPackages opts repoLoc+    forM_ pkgs $ \pkgId -> symlink (`repoLayoutPkgTarGz` pkgId)+  where+    -- TODO: This gives a warning for files that we previously linked, as well+    -- as for files that we _never_ need to link (because the location of both+    -- repos is the same). This is potentially confusing.+    symlink :: (RepoLayout -> RepoPath) -> IO ()+    symlink file =+        catch (createSymbolicLink target loc) $ \ex ->+          if isAlreadyExistsError ex+            then logWarn opts $ "Skipping " ++ pretty (file globalRepoLayout)+                             ++ " (already exists)"+            else throwIO ex+      where+        target = anchorRepoPath opts  repoLoc      file+        loc    = anchorRepoPath opts' cabalRepoLoc file+        opts'  = opts { globalRepoLayout = cabalLocalRepoLayout }++{-------------------------------------------------------------------------------+  Signing individual files+-------------------------------------------------------------------------------}++signFile :: [KeyLoc] -> DeleteExistingSignatures -> Path Absolute -> IO ()+signFile keyLocs deleteExisting fp = do+    UninterpretedSignatures (payload :: JSValue) oldSigs <-+      throwErrors =<< readJSON_NoKeys_NoLayout fp+    keys :: [Some Key] <- forM keyLocs $ \keyLoc ->+      throwErrors =<< readJSON_NoKeys_NoLayout keyLoc+    let newSigs = concat [+            if deleteExisting then [] else oldSigs+          , toPreSignatures (signRendered keys $ renderJSON_NoLayout payload)+          ]+    writeJSON_NoLayout fp $ UninterpretedSignatures payload newSigs++{-------------------------------------------------------------------------------+  Logging+-------------------------------------------------------------------------------}++logInfo :: GlobalOpts -> String -> IO ()+logInfo GlobalOpts{..} str = when globalVerbose $+    putStrLn $ "Info: " ++ str++logWarn :: GlobalOpts -> String -> IO ()+logWarn _opts str =+    putStrLn $ "Warning: " ++ str++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Check that a file has the given extensions+--+-- Returns the filename without the verified extensions. For example:+--+-- > hasExtensions "foo.tar.gz" [".tar", ".gz"] == Just "foo"+hasExtensions :: Path a -> [String] -> Maybe String+hasExtensions = \fp exts -> go (takeFileName fp) (reverse exts)+  where+    go :: FilePath -> [String] -> Maybe String+    go fp []     = return fp+    go fp (e:es) = do let (fp', e') = FilePath.splitExtension fp+                      guard $ e == e'+                      go fp' es++throwErrors :: Exception e => Either e a -> IO a+throwErrors (Left err) = throwIO err+throwErrors (Right a)  = return a
+ hackage-security/hackage-repo-tool/src/Prelude.hs view
@@ -0,0 +1,27 @@+-- | Smooth over differences between various ghc versions by making older+-- preludes look like 4.8.0+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+module Prelude (+    module P+#if !MIN_VERSION_base(4,8,0)+  , Applicative(..)+  , Monoid(..)+  , (<$>)+  , (<$)+  , traverse+#endif+  ) where++#if MIN_VERSION_base(4,8,0)+import "base" Prelude as P+#else+#if MIN_VERSION_base(4,6,0)+import "base" Prelude as P+#else+import "base" Prelude as P hiding (catch)+#endif+import Control.Applicative+import Data.Monoid+import Data.Traversable (traverse)+#endif
+ hackage-security/hackage-root-tool/ChangeLog.md view
@@ -0,0 +1,4 @@+0.1.0.0+-------+* Initial hack, just to make it possible to create root keys+  and re-sign root info.
+ hackage-security/hackage-root-tool/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-root-tool/Main.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-}+module Main (main) where++import Data.Monoid+import Control.Exception+import GHC.Conc.Sync (setUncaughtExceptionHandler)+import System.Exit++-- hackage-security+import Hackage.Security.Server+import Hackage.Security.Util.Some+import Hackage.Security.Util.Path+import Text.JSON.Canonical (JSValue)++import Options.Applicative+++{-------------------------------------------------------------------------------+  Main application driver+-------------------------------------------------------------------------------}++main :: IO ()+main = do+    setUncaughtExceptionHandler topLevelExceptionHandler+    GlobalOpts{..} <- getOptions+    case globalCommand of+      CreateKeys ->+        createKeys++      Sign key file -> do+        key'  <- makeAbsolute (fromFilePath key)+        file' <- makeAbsolute (fromFilePath file)+        signFile key' file'++-- | Top-level exception handler that uses 'displayException'+--+-- Although base 4.8 introduces 'displayException', the top-level exception+-- handler still uses 'show', sadly. See "PROPOSAL: Add displayException to+-- Exception typeclass" thread on the libraries mailing list.+--+-- NOTE: This is a terrible hack. See the above thread for some insights into+-- how we should do this better. For now it will do however.+topLevelExceptionHandler :: SomeException -> IO ()+topLevelExceptionHandler e = do+    putStrLn $ displayException e+    exitFailure++#if !MIN_VERSION_base(4,8,0)+displayException :: Exception e => e -> String+displayException = show+#endif++{-------------------------------------------------------------------------------+  Creating keys+-------------------------------------------------------------------------------}++createKeys :: IO ()+createKeys = do+    privateRoot <- createKey' KeyTypeEd25519+    writeKey privateRoot++{-------------------------------------------------------------------------------+  Dealing with (private) keys+-------------------------------------------------------------------------------}++writeKey :: Some Key -> IO ()+writeKey keypair = do+    let keypath = keyIdString (someKeyId keypair)+    keypathabs <- makeAbsolute (fromFilePath keypath)++    logInfo $ "Writing new key:\n  " ++ keypath ++ ".{private,public}"++    writeJSON_NoLayout (keypathabs <.> "private") keypair+    writeJSON_NoLayout (keypathabs <.> "public")  keypublic+  where+    keypublic :: Some PublicKey+    keypublic = somePublicKey keypair++{-------------------------------------------------------------------------------+  Signing individual files+-------------------------------------------------------------------------------}++signFile :: KeyLoc -> Path Absolute -> IO ()+signFile keyLoc fp = do+    UninterpretedSignatures (payload :: JSValue) _oldSigs <-+      throwErrors =<< readJSON_NoKeys_NoLayout fp+    key :: Some Key <-+      throwErrors =<< readJSON_NoKeys_NoLayout keyLoc+    let newSig = toPreSignatures (signRendered [key]+                                               (renderJSON_NoLayout payload))+    writeJSON_NoLayout (fp <.> "sig") newSig++{-------------------------------------------------------------------------------+  Logging+-------------------------------------------------------------------------------}++logInfo :: String -> IO ()+logInfo msg = putStrLn msg++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++throwErrors :: Exception e => Either e a -> IO a+throwErrors (Left err) = throwIO err+throwErrors (Right a)  = return a++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++-- | Command line options+data GlobalOpts = GlobalOpts {++    -- | Command to execute+    globalCommand :: Command+  }++data Command =+    -- | Create keys+    CreateKeys++    -- | Sign an individual file+  | Sign FilePath FilePath++type KeyLoc = Path Absolute++{-------------------------------------------------------------------------------+  Parsers+-------------------------------------------------------------------------------}++getOptions :: IO GlobalOpts+getOptions = execParser opts+  where+    opts = info (helper <*> parseGlobalOptions) $ mconcat [+        fullDesc+      , header "Manage local Hackage repositories"+      ]++parseCreateKeys :: Parser Command+parseCreateKeys = pure CreateKeys++parseSign :: Parser Command+parseSign = Sign+  <$> argument str (metavar "KEY")+  <*> argument str (metavar "FILE")++-- | Global options+--+-- TODO: Make repo and keys layout configurable+parseGlobalOptions :: Parser GlobalOpts+parseGlobalOptions =+      GlobalOpts+  <$> (subparser $ mconcat [+          command "create-key" $ info (helper <*> parseCreateKeys) $+            progDesc "Create keys"+        , command "sign" $ info (helper <*> parseSign) $+            progDesc "Sign a file"+        ])
+ hackage-security/hackage-root-tool/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-root-tool/hackage-root-tool.cabal view
@@ -0,0 +1,34 @@+name:                hackage-root-tool+version:             0.1.0.0+synopsis:            Utility for Hackage key holders to generate keys and sign root info.+description:         A command line tool for people who hold Hackage root keys.+                     It can generate new keys, and can sign root information.+                     .+                     This is part of the Hackage Security infrastructure.+homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Duncan Coutts, Edsko de Vries+maintainer:          duncan@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:+  ChangeLog.md++source-repository head+  type:                git+  location:            http://github.com/well-typed/hackage-security+  subdir:              hackage-root-tool++executable hackage-root-tool+  main-is:             Main.hs+  build-depends:       base                 >= 4.4  && < 5,+                       filepath             >= 1.2  && < 1.5,+                       optparse-applicative >= 0.11 && < 0.13,+                       hackage-security     >= 0.2  && < 0.6+  default-language:    Haskell2010+  other-extensions:    CPP, ScopedTypeVariables, RecordWildCards+  ghc-options:         -Wall
+ hackage-security/hackage-security-HTTP/ChangeLog.md view
@@ -0,0 +1,17 @@+0.1.1+-----+* Implement updated HttpLib API from hackage-security 0.5++0.1.0.2+-------+* Allow for hackage-security 0.3.*+* Include ChangeLog.md in sdist (#98)++0.1.0.1+-------+* Allow for hackage-security 0.2.*+* Allow for network-2.5 (rather than network-uri-2.6.*)++0.1.0.0+-------+* Initial beta release
+ hackage-security/hackage-security-HTTP/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-security-HTTP/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal view
@@ -0,0 +1,55 @@+name:                hackage-security-HTTP+version:             0.1.1+synopsis:            Hackage security bindings against the HTTP library+description:         The hackage security library provides a 'HttpLib'+                     abstraction to allow to bind against different HTTP+                     libraries. This library implements this abstraction using+                     the @HTTP@ library.+homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+homepage:            https://github.com/well-typed/hackage-security+bug-reports:         https://github.com/well-typed/hackage-security/issues+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:+  ChangeLog.md++source-repository head+  type: git+  location: https://github.com/well-typed/hackage-security.git++flag use-network-uri+  description: Are we using network-uri?+  manual: False++library+  exposed-modules:     Hackage.Security.Client.Repository.HttpLib.HTTP+  build-depends:       base             >= 4.4       && < 5,+                       bytestring       >= 0.9       && < 0.11,+                       HTTP             >= 4000.2.19 && < 4000.4,+                       mtl              >= 2.2       && < 2.3,+                       zlib             >= 0.5       && < 0.7,+                       hackage-security >= 0.5       && < 0.6+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveDataTypeable+                       FlexibleContexts+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+  other-extensions:    CPP+  ghc-options:         -Wall++  -- See comments in hackage-security.cabal+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6
+ hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE CPP #-}+-- | Implementation of 'HttpClient' using the HTTP package+module Hackage.Security.Client.Repository.HttpLib.HTTP (+    withClient+    -- ** Additional operations+  , setOutHandler+  , setErrHandler+  , setProxy+  , request+    -- ** Low-level API+  , Browser -- opaque+  , withBrowser+    -- * Exception types+  , UnexpectedResponse(..)+  , InvalidProxy(..)+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.List (intercalate)+import Data.Typeable (Typeable)+import Network.URI+import qualified Data.ByteString.Lazy as BS.L+import qualified Control.Monad.State  as State+import qualified Network.Browser      as HTTP+import qualified Network.HTTP         as HTTP+import qualified Network.HTTP.Proxy   as HTTP++import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Util.Lens as Lens++{-------------------------------------------------------------------------------+  Top-level API+-------------------------------------------------------------------------------}++-- | Initialize the client+--+-- TODO: This currently uses the lazy bytestring API offered by the HTTP+-- library. Unfortunately this provides no way of closing the connection when+-- the callback decides it doens't require any further input. It seems+-- impossible however to implement a proper streaming API.+-- See <https://github.com/haskell/HTTP/issues/86>.+withClient :: (Browser -> HttpLib -> IO a) -> IO a+withClient callback =+    bracket browserInit browserCleanup $ \browser ->+      callback browser HttpLib {+          httpGet      = get      browser+        , httpGetRange = getRange browser+        }++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++get :: Throws SomeRemoteError+    => Browser+    -> [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get browser reqHeaders uri callback = wrapCustomEx $ do+    response <- request browser+      $ setRequestHeaders reqHeaders+      -- avoid silly `Content-Length: 0` header inserted by `mkRequest`+      $ removeHeader HTTP.HdrContentLength+      $ HTTP.mkRequest HTTP.GET uri+    case HTTP.rspCode response of+      (2, 0, 0) -> withResponse response callback+      otherCode -> throwChecked $ UnexpectedResponse uri otherCode++getRange :: Throws SomeRemoteError+         => Browser+         -> [HttpRequestHeader] -> URI -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange browser reqHeaders uri (from, to) callback = wrapCustomEx $ do+    response <- request browser+      $ setRange from to+      $ setRequestHeaders reqHeaders+      -- avoid silly `Content-Length: 0` header inserted by `mkRequest`+      $ removeHeader HTTP.HdrContentLength+      $ HTTP.mkRequest HTTP.GET uri+    case HTTP.rspCode response of+      (2, 0, 0) -> withResponse response $ callback HttpStatus200OK+      (2, 0, 6) -> withResponse response $ callback HttpStatus206PartialContent+      otherCode -> throwChecked $ UnexpectedResponse uri otherCode++removeHeader :: HTTP.HasHeaders a => HTTP.HeaderName -> a -> a+removeHeader name h = HTTP.setHeaders h newHeaders+  where+    newHeaders = [ x | x@(HTTP.Header n _) <- HTTP.getHeaders h, name /= n ]++{-------------------------------------------------------------------------------+  Auxiliary methods used to implement the HttpClient interface+-------------------------------------------------------------------------------}++withResponse :: Throws SomeRemoteError+             => HTTP.Response BS.L.ByteString+             -> ([HttpResponseHeader] -> BodyReader -> IO a)+             -> IO a+withResponse response callback = wrapCustomEx $ do+    br <- bodyReaderFromBS $ HTTP.rspBody response+    callback responseHeaders $ wrapCustomEx br+  where+    responseHeaders = getResponseHeaders response++{-------------------------------------------------------------------------------+  Custom exception types+-------------------------------------------------------------------------------}++wrapCustomEx :: ( ( Throws UnexpectedResponse+                  , Throws IOException+                  ) => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ handleChecked (\(ex :: IOException)        -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)++data UnexpectedResponse = UnexpectedResponse URI (Int, Int, Int)+  deriving (Typeable)++data InvalidProxy = InvalidProxy String+  deriving (Typeable)++instance Pretty UnexpectedResponse where+  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code+                                      ++ "for " ++ show uri++instance Pretty InvalidProxy where+  pretty (InvalidProxy p) = "Invalid proxy " ++ show p++#if MIN_VERSION_base(4,8,0)+deriving instance Show UnexpectedResponse+deriving instance Show InvalidProxy+instance Exception UnexpectedResponse where displayException = pretty+instance Exception InvalidProxy where displayException = pretty+#else+instance Show UnexpectedResponse where show = pretty+instance Show InvalidProxy where show = pretty+instance Exception UnexpectedResponse+instance Exception InvalidProxy+#endif++{-------------------------------------------------------------------------------+  Additional operations+-------------------------------------------------------------------------------}++setProxy :: Browser -> ProxyConfig String -> IO ()+setProxy browser proxyConfig = do+    proxy <- case proxyConfig of+      ProxyConfigNone  -> return HTTP.NoProxy+      ProxyConfigAuto  -> HTTP.fetchProxy True+      ProxyConfigUse p -> case HTTP.parseProxy p of+                             Nothing -> throwUnchecked $ InvalidProxy p+                             Just p' -> return p'+    withBrowser browser $ HTTP.setProxy (emptyAsNone proxy)+  where+    emptyAsNone :: HTTP.Proxy -> HTTP.Proxy+    emptyAsNone (HTTP.Proxy uri _) | null uri = HTTP.NoProxy+    emptyAsNone p = p++setOutHandler :: Browser -> (String -> IO ()) -> IO ()+setOutHandler browser = withBrowser browser . HTTP.setOutHandler++setErrHandler :: Browser -> (String -> IO ()) -> IO ()+setErrHandler browser = withBrowser browser . HTTP.setErrHandler++-- | Execute a single request+request :: Throws IOException+        => Browser+        -> HTTP.Request BS.L.ByteString+        -> IO (HTTP.Response BS.L.ByteString)+request browser = checkIO . liftM snd . withBrowser browser . HTTP.request++{-------------------------------------------------------------------------------+  Browser state+-------------------------------------------------------------------------------}++type LazyStream = HTTP.HandleStream BS.L.ByteString++data Browser = Browser {+    browserState :: MVar (HTTP.BrowserState LazyStream)+  }++-- | Run a browser action+--+-- IMPLEMENTATION NOTE: the 'browse' action doesn't itself create any+-- connections, they are created on demand; we just need to make sure to carry+-- this state from one invocation of 'browse' to another.+withBrowser :: forall a. Browser -> HTTP.BrowserAction LazyStream a -> IO a+withBrowser Browser{..} act = modifyMVar browserState $ \bst -> HTTP.browse $ do+    State.put bst+    result <- act+    bst'   <- State.get+    return (bst', result)++-- | Initial browser state+--+-- Throws an 'InvalidProxy' exception if the proxy definition is invalid.+--+-- TODO: If the proxy configuration is automatic, the _only_ way that we can+-- find out from the @HTTP@ library is to pass @True@ as the argument to+-- 'fetchProxy'; but this prints to standard error when the proxy is invalid,+-- rather than throwing an exception :-O+browserInit :: IO Browser+browserInit = do+    browserState <- newMVar =<< HTTP.browse State.get+    return Browser{..}++-- | Cleanup browser state+--+-- NOTE: Calling 'withBrowser' after 'browserCleanup' will result in deadlock.+--+-- IMPLEMENTATION NOTE: "HTTP" does not provide any explicit API for resource+-- cleanup, so we can only rely on the garbage collector to do for us.+browserCleanup :: Browser -> IO ()+browserCleanup Browser{..} = void $ takeMVar browserState++{-------------------------------------------------------------------------------+  HTTP auxiliary+-------------------------------------------------------------------------------}++hAcceptRanges :: HTTP.HeaderName+hAcceptRanges = HTTP.HdrCustom "Accept-Ranges"++setRange :: HTTP.HasHeaders a => Int -> Int -> a -> a+setRange from to = HTTP.insertHeader HTTP.HdrRange rangeHeader+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)++setRequestHeaders :: HTTP.HasHeaders a => [HttpRequestHeader] -> a -> a+setRequestHeaders =+    foldr (.) id . map (uncurry HTTP.insertHeader) . trOpt []+  where+    trOpt :: [(HTTP.HeaderName, [String])]+          -> [HttpRequestHeader]+          -> [(HTTP.HeaderName, String)]+    trOpt acc [] =+      concatMap finalizeHeader acc+    trOpt acc (HttpRequestMaxAge0:os) =+      trOpt (insert HTTP.HdrCacheControl ["max-age=0"] acc) os+    trOpt acc (HttpRequestNoTransform:os) =+      trOpt (insert HTTP.HdrCacheControl ["no-transform"] acc) os++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we we just comma-separate all of them.+    finalizeHeader :: (HTTP.HeaderName, [String]) -> [(HTTP.HeaderName, String)]+    finalizeHeader (name, strs) = [(name, intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = Lens.modify (Lens.lookupM x) (++ y)++getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]+getResponseHeaders response = concat [+    -- Check the @Accept-Ranges@ header.+    --+    -- @Accept-Ranges@ takes a _single_ argument, but there might potentially+    -- be more than one of them (although the spec does not explicitly say so).++    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.5>+    -- and <http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.12>+    [ HttpResponseAcceptRangesBytes+    | "bytes" `elem` map HTTP.hdrValue (HTTP.retrieveHeaders hAcceptRanges response)+    ]+  ]
+ hackage-security/hackage-security-curl/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-security-curl/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-security-curl/hackage-security-curl.cabal view
@@ -0,0 +1,33 @@+name:                hackage-security-curl+version:             0.1.0.0+synopsis:            Hackage security bindings against curl (and other external downloaders)+homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++flag use-network-uri+  description: Are we using network-uri?+  manual: False++library+  exposed-modules:     Hackage.Security.Client.Repository.HttpLib.Curl+  build-depends:       base        >= 4.4,+                       bytestring  >= 0.9,+                       process     >= 1.1,+                       hackage-security+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++  -- See comments in hackage-security.cabal+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6
+ hackage-security/hackage-security-curl/src/Hackage/Security/Client/Repository/HttpLib/Curl.hs view
@@ -0,0 +1,70 @@+-- | Implementation of 'HttpClient' using external downloader+module Hackage.Security.Client.Repository.HttpLib.Curl (+    withClient+  ) where++import Control.Monad+import Network.URI+import System.Process+import System.IO+import qualified Data.ByteString               as BS+import qualified Data.ByteString.Lazy.Internal as BS.L++import Hackage.Security.Client.Repository.HttpLib++{-------------------------------------------------------------------------------+  Top-level API+-------------------------------------------------------------------------------}++-- | HttpClient using external 'curl' executable+--+-- This is currently just a proof of concept. With a bit of luck we'll be+-- able to reuse most of https://github.com/haskell/cabal/pull/2613 for a+-- more serious implementation. Current TODOs:+--+-- * Set HTTP request headers in 'get'+-- * Get HTTP response headers in 'get'+-- * Support range requests+-- * Deal with proxy settings+-- * Configure logging+--+-- Probably we will want to add a @Browser@ or @Manager@ like abstraction (see+-- @hackage-security-HTTP@ and @hackage-security-http-client@, respectively)+-- in order to allow to change settings as we go.+withClient :: (HttpLib -> IO a) -> IO a+withClient callback = do+    callback HttpLib {+      httpGet      = get+    , httpGetRange = undefined -- TODO: support range requests+    }++{-------------------------------------------------------------------------------+  Implementation of the individual methods+-------------------------------------------------------------------------------}++get :: [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get _httpOpts uri callback = do+    (Nothing, Just hOut, Nothing, hProc) <- createProcess curl+    callback [] (bodyReader hProc hOut)+  where+    curl :: CreateProcess+    curl = (proc "curl" [show uri]) { std_out = CreatePipe }++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Construct a body reader for a process+--+-- TODO: We should also deal with stderr+-- TODO: Perhaps this should be in the main library, alongside bodyReaderFromBS.+bodyReader :: ProcessHandle -> Handle -> BodyReader+bodyReader hProc hOut = do+    chunk <- BS.hGetSome hOut BS.L.smallChunkSize+    when (BS.null chunk) $ do+      _exitCode <- waitForProcess hProc+      -- TODO: Check for successful termination+      return ()+    return chunk
+ hackage-security/hackage-security-http-client/ChangeLog.md view
@@ -0,0 +1,7 @@+0.1.1+-----+* Implement updated HttpLib API from hackage-security 0.5++0.1.0.0+-------+* Initial beta release
+ hackage-security/hackage-security-http-client/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-security-http-client/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-security-http-client/hackage-security-http-client.cabal view
@@ -0,0 +1,39 @@+name:                hackage-security-http-client+version:             0.1.1+synopsis:            Hackage security bindings for the http-client library+homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++flag use-network-uri+  description: Are we using network-uri?+  manual: False++library+  exposed-modules:     Hackage.Security.Client.Repository.HttpLib.HttpClient+  build-depends:       base               >= 4.4,+                       bytestring         >= 0.9,+                       data-default-class >= 0.0,+                       http-client        >= 0.4,+                       http-types         >= 0.8,+                       hackage-security   >= 0.5 && < 0.6+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  FlexibleContexts+                       RankNTypes+                       ScopedTypeVariables+  other-extensions:    OverloadedStrings+  ghc-options:         -Wall++  -- see comments in hackage-security.cabal+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6
+ hackage-security/hackage-security-http-client/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}+module Hackage.Security.Client.Repository.HttpLib.HttpClient (+    withClient+    -- ** Re-exports+  , Manager -- opaque+  ) where++import Control.Exception+import Data.ByteString (ByteString)+import Data.Default.Class (def)+import Network.URI+import Network.HTTP.Client (Manager)+import qualified Data.ByteString              as BS+import qualified Data.ByteString.Char8        as BS.C8+import qualified Network.HTTP.Client          as HttpClient+import qualified Network.HTTP.Client.Internal as HttpClient+import qualified Network.HTTP.Types           as HttpClient++import Hackage.Security.Client hiding (Header)+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import qualified Hackage.Security.Util.Lens as Lens++{-------------------------------------------------------------------------------+  Top-level API+-------------------------------------------------------------------------------}++-- | Initialization+--+-- The proxy must be specified at initialization because @http-client@ does not+-- allow to change the proxy once the 'Manager' is created.+withClient :: ProxyConfig HttpClient.Proxy -> (Manager -> HttpLib -> IO a) -> IO a+withClient proxyConfig callback = do+    manager <- HttpClient.newManager (setProxy HttpClient.defaultManagerSettings)+    callback manager HttpLib {+        httpGet      = get      manager+      , httpGetRange = getRange manager+      }+  where+    setProxy = HttpClient.managerSetProxy $+      case proxyConfig of+        ProxyConfigNone  -> HttpClient.noProxy+        ProxyConfigUse p -> HttpClient.useProxy p+        ProxyConfigAuto  -> HttpClient.proxyEnvironment Nothing++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++get :: Throws SomeRemoteError+    => Manager+    -> [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get manager reqHeaders uri callback = wrapCustomEx $ do+    -- TODO: setUri fails under certain circumstances; in particular, when+    -- the URI contains URL auth. Not sure if this is a concern.+    request' <- HttpClient.setUri def uri+    let request = setRequestHeaders reqHeaders+                $ request'+    checkHttpException $ HttpClient.withResponse request manager $ \response -> do+      let br = wrapCustomEx $ HttpClient.responseBody response+      callback (getResponseHeaders response) br++getRange :: Throws SomeRemoteError+         => Manager+         -> [HttpRequestHeader] -> URI -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do+    request' <- HttpClient.setUri def uri+    let request = setRange from to+                $ setRequestHeaders reqHeaders+                $ request'+    checkHttpException $ HttpClient.withResponse request manager $ \response -> do+      let br = wrapCustomEx $ HttpClient.responseBody response+      case () of+         () | HttpClient.responseStatus response == HttpClient.partialContent206 ->+           callback HttpStatus206PartialContent (getResponseHeaders response) br+         () | HttpClient.responseStatus response == HttpClient.ok200 ->+           callback HttpStatus200OK (getResponseHeaders response) br+         _otherwise ->+           throwChecked $ HttpClient.StatusCodeException+                            (HttpClient.responseStatus    response)+                            (HttpClient.responseHeaders   response)+                            (HttpClient.responseCookieJar response)++-- | Wrap custom exceptions+--+-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@+-- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116>+wrapCustomEx :: (Throws HttpClient.HttpException => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: HttpClient.HttpException) -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)++checkHttpException :: Throws HttpClient.HttpException => IO a -> IO a+checkHttpException = handle $ \(ex :: HttpClient.HttpException) ->+                       throwChecked ex++{-------------------------------------------------------------------------------+  http-client auxiliary+-------------------------------------------------------------------------------}++hAcceptRanges :: HttpClient.HeaderName+hAcceptRanges = "Accept-Ranges"++hAcceptEncoding :: HttpClient.HeaderName+hAcceptEncoding = "Accept-Encoding"++setRange :: Int -> Int+         -> HttpClient.Request -> HttpClient.Request+setRange from to req = req {+      HttpClient.requestHeaders = (HttpClient.hRange, rangeHeader)+                                : HttpClient.requestHeaders req+    }+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1)++-- | Set request headers+setRequestHeaders :: [HttpRequestHeader]+                  -> HttpClient.Request -> HttpClient.Request+setRequestHeaders opts req = req {+      HttpClient.requestHeaders = trOpt disallowCompressionByDefault opts+    }+  where+    trOpt :: [(HttpClient.HeaderName, [ByteString])]+          -> [HttpRequestHeader]+          -> [HttpClient.Header]+    trOpt acc [] =+      concatMap finalizeHeader acc+    trOpt acc (HttpRequestMaxAge0:os) =+      trOpt (insert HttpClient.hCacheControl ["max-age=0"] acc) os+    trOpt acc (HttpRequestNoTransform:os) =+      trOpt (insert HttpClient.hCacheControl ["no-transform"] acc) os++    -- disable content compression (potential security issue)+    disallowCompressionByDefault :: [(HttpClient.HeaderName, [ByteString])]+    disallowCompressionByDefault = [(hAcceptEncoding, [])]++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we we just comma-separate all of them.+    finalizeHeader :: (HttpClient.HeaderName, [ByteString])+                   -> [HttpClient.Header]+    finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = Lens.modify (Lens.lookupM x) (++ y)++-- | Extract the response headers+getResponseHeaders :: HttpClient.Response a -> [HttpResponseHeader]+getResponseHeaders response = concat [+      [ HttpResponseAcceptRangesBytes+      | (hAcceptRanges, "bytes") `elem` headers+      ]+    ]+  where+    headers = HttpClient.responseHeaders response
+ hackage-security/hackage-security/ChangeLog.md view
@@ -0,0 +1,58 @@+0.5.0.2+-------+* Use tar 0.5.0+* Relax lower bound on directory++0.5.0.1+-------+* Relaxed dependency bounds++0.5.0.0+-------+* Treat deserialization errors as verification errors (#108, #75)+* Avoid `Content-Length: 0` in GET requests (#103)+* Fix bug in Trusted+* Build tar-index incrementally (#22)+* Generalize 'Repository' over the representation of downloaded remote files.+* Update index incrementally by downloading delta of `.tar.gz` and writing only+  tail of local `.tar` file (#101). Content compression no longer used.+* Take a lock on the cache directory before updating it, and no longer use+  atomic file ops (pointless since we now update some files incrementally)+* Code refactoring/simplification.+* Support for ed25519 >= 0.0.4+* `downloadPackage` no longer takes a callback.+* API for accessing the Hackage index contents changed; it should now be+  easier for clients to do their own incremental updates should they wish+  to do so.+* Relies on tar >= 0.4.4+* Removed obsolete option for downloading the compressed index (we now _always_+  download the compressed index)+* Path module now works on Windows (#118)+* Dropped support for ghc 7.2+* Replaced uses of Int with Int54, to make sure canonical JSON really is+  canonical (#141).++0.4.0.0+-------+* Allow clients to pass in their own time for expiry verification+  (this is an API change hence the major version bump)+* Export .Client.Formats (necessary to define new Repositories)+* Start work on basic test framework++0.3.0.0+-------+* Don't use compression for range requests (#101)+* Download index.tar.gz, not index.tar, if range request fails (#99)+* Minor change in the LogMessage type (hence the API version bumb)+* Include ChangeLog.md in the tarball (#98)++0.2.0.0+-------+* Allow for network-2.5 (rather than network-uri-2.6)+* Use cryptohash rather than SHA+* Various bugfixes+* API change: introduce RepoOpts in the Remote repository++0.1.0.0+-------+* Initial beta release
+ hackage-security/hackage-security/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/hackage-security/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/hackage-security/hackage-security.cabal view
@@ -0,0 +1,232 @@+name:                hackage-security+version:             0.5.0.2+synopsis:            Hackage security library+description:         The hackage security library provides both server and+                     client utilities for securing the Hackage package server+                     (<http://hackage.haskell.org/>).  It is based on The Update+                     Framework (<http://theupdateframework.com/>), a set of+                     recommendations developed by security researchers at+                     various universities in the US as well as developers on the+                     Tor project (<https://www.torproject.org/>).+                     .+                     The current implementation supports only index signing,+                     thereby enabling untrusted mirrors. It does not yet provide+                     facilities for author package signing.+                     .+                     The library has two main entry points:+                     "Hackage.Security.Client" is the main entry point for+                     clients (the typical example being @cabal@), and+                     "Hackage.Security.Server" is the main entry point for+                     servers (the typical example being @hackage-server@).+                     .+                     This is a beta release.+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+homepage:            https://github.com/well-typed/hackage-security+bug-reports:         https://github.com/well-typed/hackage-security/issues+build-type:          Simple+cabal-version:       >=1.10++extra-source-files:+  ChangeLog.md++source-repository head+  type: git+  location: https://github.com/well-typed/hackage-security.git++flag base48+  description: Are we using base 4.8 or later?+  manual: False++flag use-network-uri+  description: Are we using network-uri?+  manual: False++library+  -- Most functionality is exported through the top-level entry points .Client+  -- and .Server; the other exported modules are intended for qualified imports.+  exposed-modules:     Hackage.Security.Client+                       Hackage.Security.Client.Formats+                       Hackage.Security.Client.Repository+                       Hackage.Security.Client.Repository.Cache+                       Hackage.Security.Client.Repository.Local+                       Hackage.Security.Client.Repository.Remote+                       Hackage.Security.Client.Repository.HttpLib+                       Hackage.Security.Client.Verify+                       Hackage.Security.JSON+                       Hackage.Security.Key.Env+                       Hackage.Security.Server+                       Hackage.Security.Trusted+                       Hackage.Security.TUF.FileMap+                       Hackage.Security.Util.Checked+                       Hackage.Security.Util.IO+                       Hackage.Security.Util.Lens+                       Hackage.Security.Util.Path+                       Hackage.Security.Util.Pretty+                       Hackage.Security.Util.Some+                       Text.JSON.Canonical+  other-modules:       Hackage.Security.Key+                       Hackage.Security.Trusted.TCB+                       Hackage.Security.TUF+                       Hackage.Security.TUF.Common+                       Hackage.Security.TUF.FileInfo+                       Hackage.Security.TUF.Header+                       Hackage.Security.TUF.Layout.Cache+                       Hackage.Security.TUF.Layout.Index+                       Hackage.Security.TUF.Layout.Repo+                       Hackage.Security.TUF.Mirrors+                       Hackage.Security.TUF.Paths+                       Hackage.Security.TUF.Patterns+                       Hackage.Security.TUF.Root+                       Hackage.Security.TUF.Signed+                       Hackage.Security.TUF.Snapshot+                       Hackage.Security.TUF.Targets+                       Hackage.Security.TUF.Timestamp+                       Hackage.Security.Util.Base64+                       Hackage.Security.Util.JSON+                       Hackage.Security.Util.Stack+                       Hackage.Security.Util.TypedEmbedded+                       Prelude+  -- We support ghc 7.4 (bundled with Cabal 1.14) and up+  build-depends:       base              >= 4.5     && < 5,+                       base64-bytestring >= 1.0     && < 1.1,+                       bytestring        >= 0.9     && < 0.11,+                       Cabal             >= 1.14    && < 1.26,+                       containers        >= 0.4     && < 0.6,+                       directory         >= 1.1.0.2 && < 1.3,+                       ed25519           >= 0.0     && < 0.1,+                       filepath          >= 1.2     && < 1.5,+                       mtl               >= 2.2     && < 2.3,+                       parsec            >= 3.1     && < 3.2,+                       cryptohash        >= 0.11    && < 0.12,+                       -- 0.4.2 introduces TarIndex, 0.4.4 introduces more+                       -- functionality, 0.5.0 changes type of serialise+                       tar               >= 0.5     && < 0.6,+                       time              >= 1.2     && < 1.7,+                       transformers      >= 0.4     && < 0.6,+                       zlib              >= 0.5     && < 0.7,+                       -- whatever versions are bundled with ghc:+                       template-haskell,+                       ghc-prim+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DefaultSignatures+                       DeriveDataTypeable+                       DeriveFunctor+                       FlexibleContexts+                       FlexibleInstances+                       GADTs+                       GeneralizedNewtypeDeriving+                       KindSignatures+                       MultiParamTypeClasses+                       NamedFieldPuns+                       NoMonomorphismRestriction+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+                       TupleSections+                       TypeFamilies+                       TypeOperators+                       ViewPatterns+  other-extensions:    BangPatterns+                       CPP+                       OverlappingInstances+                       PackageImports+                       UndecidableInstances+  -- use the new stage1/cross-compile-friendly Quotes subset of TH for new GHCs+  if impl(ghc >= 8.0)+    -- place holder until Hackage allows to edit in the new extension token+    -- other-extensions: TemplateHaskellQuotes+    other-extensions:+  else+    other-extensions: TemplateHaskell++  ghc-options:         -Wall++  if flag(base48)+    build-depends: base >= 4.8+  else+    build-depends: old-locale >= 1.0++  -- The URI type got split out off the network package after version 2.5, and+  -- moved to a separate network-uri package. Since we don't need the rest of+  -- network here, it would suffice to rely only on network-uri:+  --+  -- > if flag(use-network-uri)+  -- >   build-depends: network-uri >= 2.6 && < 2.7+  -- > else+  -- >   build-depends: network     >= 2.5 && < 2.6+  --+  -- However, if we did the same in hackage-security-HTTP, Cabal would consider+  -- those two flag choices (hackage-security:use-network-uri and+  -- hackage-security-HTTP:use-network-uri) to be completely independent; but+  -- they aren't: if it links hackage-security against network-uri and+  -- hackage-security-HTTP against network, we will get type errors when+  -- hackage-security-HTTP tries to pass a URI to hackage-security.+  --+  -- It might seem we can solve this problem by re-exporting the URI type in+  -- hackage-security and avoid the dependency in hackage-security-HTTP+  -- altogether. However, this merely shifts the problem: hackage-security-HTTP+  -- relies on the HTTP library which--surprise!--makes the same choice between+  -- depending on network or network-uri. Cabal will not notice that we cannot+  -- build hackage-security and hackage-security-HTTP against network-uri but+  -- HTTP against network.+  --+  -- We solve the problem by explicitly relying on network-2.6 when choosing+  -- network-uri. This dependency is redundant, strictly speaking. However, it+  -- serves as a proxy for forcing flag choices: since all packages in a+  -- solution must be linked against the same version of network, having one+  -- version of network in one branch of the conditional and another version of+  -- network in the other branch forces the choice to be consistent throughout.+  -- (Note that the HTTP library does the same thing, though in this case the+  -- dependency in network is not redundant.)+  if flag(use-network-uri)+    build-depends: network-uri >= 2.6 && < 2.7,+                   network     >= 2.6 && < 2.7+  else+    build-depends: network     >= 2.5 && < 2.6++  if impl(ghc >= 7.8)+     other-extensions: RoleAnnotations++  if impl(ghc >= 7.10)+     other-extensions: AllowAmbiguousTypes+--                       StaticPointers+-- ^^^ Temporarily disabled because Hackage doesn't know yet about this+-- extension and will therefore reject this package.++test-suite TestSuite+  type:                exitcode-stdio-1.0+  main-is:             TestSuite.hs+  other-modules:       TestSuite.InMemCache+                       TestSuite.InMemRepo+                       TestSuite.InMemRepository+                       TestSuite.PrivateKeys+                       TestSuite.Util.StrictMVar+  build-depends:       base,+                       Cabal,+                       containers,+                       HUnit,+                       bytestring,+                       hackage-security,+                       network-uri,+                       tar,+                       tasty,+                       tasty-hunit,+                       temporary,+                       time,+                       zlib+  hs-source-dirs:      tests+  default-language:    Haskell2010+  default-extensions:  FlexibleContexts+                       GADTs+                       KindSignatures+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+  ghc-options:         -Wall
+ hackage-security/hackage-security/src/Hackage/Security/Client.hs view
@@ -0,0 +1,1031 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE StaticPointers #-}+#endif+-- | Main entry point into the Hackage Security framework for clients+module Hackage.Security.Client (+    -- * Checking for updates+    checkForUpdates+  , HasUpdates(..)+    -- * Downloading targets+  , downloadPackage+  , downloadPackage'+    -- * Access to the Hackage index+  , Directory(..)+  , DirectoryEntry(..)+  , getDirectory+  , IndexFile(..)+  , IndexEntry(..)+  , IndexCallbacks(..)+  , withIndex+    -- * Bootstrapping+  , requiresBootstrap+  , bootstrap+    -- * Re-exports+  , module Hackage.Security.TUF+  , module Hackage.Security.Key+  , trusted+    -- ** We only a few bits from .Repository+    -- TODO: Maybe this is a sign that these should be in a different module?+  , Repository -- opaque+  , DownloadedFile(..)+  , SomeRemoteError(..)+  , LogMessage(..)+    -- * Exceptions+  , uncheckClientErrors+  , VerificationError(..)+  , VerificationHistory+  , RootUpdated(..)+  , InvalidPackageException(..)+  , InvalidFileInIndex(..)+  , LocalFileCorrupted(..)+  ) where++import Prelude hiding (log)+import Control.Arrow (first)+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.List (sortBy)+import Data.Maybe (isNothing)+import Data.Ord (comparing)+import Data.Time+import Data.Traversable (for)+import Data.Typeable (Typeable)+import qualified Codec.Archive.Tar          as Tar+import qualified Codec.Archive.Tar.Entry    as Tar+import qualified Codec.Archive.Tar.Index    as Tar+import qualified Data.ByteString.Lazy       as BS.L+import qualified Data.ByteString.Lazy.Char8 as BS.L.C8++import Distribution.Package (PackageIdentifier)+import Distribution.Text (display)++import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.Client.Verify+import Hackage.Security.JSON+import Hackage.Security.Key+import Hackage.Security.Key.Env (KeyEnv)+import Hackage.Security.Trusted+import Hackage.Security.Trusted.TCB+import Hackage.Security.TUF+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some+import Hackage.Security.Util.Stack+import qualified Hackage.Security.Key.Env as KeyEnv++{-------------------------------------------------------------------------------+  Checking for updates+-------------------------------------------------------------------------------}++data HasUpdates = HasUpdates | NoUpdates+  deriving (Show, Eq, Ord)++-- | Generic logic for checking if there are updates+--+-- This implements the logic described in Section 5.1, "The client application",+-- of the TUF spec. It checks which of the server metadata has changed, and+-- downloads all changed metadata to the local cache. (Metadata here refers+-- both to the TUF security metadata as well as the Hackage packge index.)+--+-- You should pass @Nothing@ for the UTCTime _only_ under exceptional+-- circumstances (such as when the main server is down for longer than the+-- expiry dates used in the timestamp files on mirrors).+checkForUpdates :: (Throws VerificationError, Throws SomeRemoteError)+                => Repository down+                -> Maybe UTCTime -- ^ To check expiry times against (if using)+                -> IO HasUpdates+checkForUpdates rep@Repository{..} mNow =+    withMirror rep $ limitIterations []+  where+    -- More or less randomly chosen maximum iterations+    -- See <https://github.com/theupdateframework/tuf/issues/287>.+    maxNumIterations :: Int+    maxNumIterations = 5++    -- The spec stipulates that on a verification error we must download new+    -- root information and start over. However, in order to prevent DoS attacks+    -- we limit how often we go round this loop.+    -- See als <https://github.com/theupdateframework/tuf/issues/287>.+    limitIterations :: (Throws VerificationError, Throws SomeRemoteError)+                    => VerificationHistory -> IO HasUpdates+    limitIterations history | length history >= maxNumIterations =+        throwChecked $ VerificationErrorLoop (reverse history)+    limitIterations history = do+        -- Get all cached info+        --+        -- NOTE: Although we don't normally update any cached files until the+        -- whole verification process successfully completes, in case of a+        -- verification error, or in case of a regular update of the root info,+        -- we DO update the local files. Hence, we must re-read all local files+        -- on each iteration.+        cachedInfo <- getCachedInfo rep++        mHasUpdates <- tryChecked -- catch RootUpdated+                     $ tryChecked -- catch VerificationError+                     $ runVerify repLockCache+                     $ go attemptNr cachedInfo+        case mHasUpdates of+          Left ex -> do+            -- NOTE: This call to updateRoot is not itself protected by an+            -- exception handler, and may therefore throw a VerificationError.+            -- This is intentional: if we get verification errors during the+            -- update process, _and_ we cannot update the main root info, then+            -- we cannot do anything.+            log rep $ LogVerificationError ex+            let history'   = Right ex : history+                attemptNr' = attemptNr + 1+            updateRoot rep mNow attemptNr' cachedInfo (Left ex)+            limitIterations history'+          Right (Left RootUpdated) -> do+            log rep $ LogRootUpdated+            let history' = Left RootUpdated : history+            limitIterations history'+          Right (Right hasUpdates) ->+            return hasUpdates+      where+        attemptNr :: AttemptNr+        attemptNr = fromIntegral $ length history++    -- The 'Verify' monad only caches the downloaded files after verification.+    -- See also <https://github.com/theupdateframework/tuf/issues/283>.+    go :: Throws RootUpdated => AttemptNr -> CachedInfo -> Verify HasUpdates+    go attemptNr cachedInfo@CachedInfo{..} = do+      -- Get the new timestamp+      newTS <- getRemoteFile' RemoteTimestamp+      let newInfoSS = static timestampInfoSnapshot <$$> newTS++      -- Check if the snapshot has changed+      if not (fileChanged cachedInfoSnapshot newInfoSS)+        then return NoUpdates+        else do+          -- Get the new snapshot+          newSS <- getRemoteFile' (RemoteSnapshot newInfoSS)+          let newInfoRoot    = static snapshotInfoRoot    <$$> newSS+              newInfoMirrors = static snapshotInfoMirrors <$$> newSS+              newInfoTarGz   = static snapshotInfoTarGz   <$$> newSS+              mNewInfoTar    = trustElems (static snapshotInfoTar <$$> newSS)++          -- If root metadata changed, download and restart+          when (rootChanged cachedInfoRoot newInfoRoot) $ liftIO $ do+            updateRoot rep mNow attemptNr cachedInfo (Right newInfoRoot)+            -- By throwing 'RootUpdated' as an exception we make sure that+            -- any files previously downloaded (to temporary locations)+            -- will not be cached.+            throwChecked RootUpdated++          -- If mirrors changed, download and verify+          when (fileChanged cachedInfoMirrors newInfoMirrors) $+            newMirrors =<< getRemoteFile' (RemoteMirrors newInfoMirrors)++          -- If index changed, download and verify+          when (fileChanged cachedInfoTarGz newInfoTarGz) $+            updateIndex newInfoTarGz mNewInfoTar++          return HasUpdates+      where+        getRemoteFile' :: ( VerifyRole a+                          , FromJSON ReadJSON_Keys_Layout (Signed a)+                          )+                       => RemoteFile (f :- ()) Metadata -> Verify (Trusted a)+        getRemoteFile' = liftM fst . getRemoteFile rep cachedInfo attemptNr mNow++        -- Update the index and check against the appropriate hash+        updateIndex :: Trusted FileInfo         -- info about @.tar.gz@+                    -> Maybe (Trusted FileInfo) -- info about @.tar@+                    -> Verify ()+        updateIndex newInfoTarGz Nothing = do+          (targetPath, tempPath) <- getRemote' rep attemptNr $+            RemoteIndex (HFZ FGz) (FsGz newInfoTarGz)+          verifyFileInfo' (Just newInfoTarGz) targetPath tempPath+        updateIndex newInfoTarGz (Just newInfoTar) = do+          (format, targetPath, tempPath) <- getRemote rep attemptNr $+            RemoteIndex (HFS (HFZ FGz)) (FsUnGz newInfoTar newInfoTarGz)+          case format of+            Some FGz -> verifyFileInfo' (Just newInfoTarGz) targetPath tempPath+            Some FUn -> verifyFileInfo' (Just newInfoTar)   targetPath tempPath++    -- Unlike for other files, if we didn't have an old snapshot, consider the+    -- root info unchanged (otherwise we would loop indefinitely).+    -- See also <https://github.com/theupdateframework/tuf/issues/286>+    rootChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool+    rootChanged Nothing    _   = False+    rootChanged (Just old) new = not (trustedFileInfoEqual old new)++    -- For any file other than the root we consider the file to have changed+    -- if we do not yet have a local snapshot to tell us the old info.+    fileChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool+    fileChanged Nothing    _   = True+    fileChanged (Just old) new = not (trustedFileInfoEqual old new)++    -- We don't actually _do_ anything with the mirrors file until the next call+    -- to 'checkUpdates', because we want to use a single server for a single+    -- check-for-updates request. If validation was successful the repository+    -- will have cached the mirrors file and it will be available on the next+    -- request.+    newMirrors :: Trusted Mirrors -> Verify ()+    newMirrors _ = return ()++-- | Update the root metadata+--+-- Note that the new root metadata is verified using the old root metadata,+-- and only then trusted.+--+-- We don't always have root file information available. If we notice during+-- the normal update process that the root information has changed then the+-- snapshot will give us the new file information; but if we need to update+-- the root information due to a verification error we do not.+--+-- We additionally delete the cached cached snapshot and timestamp. This is+-- necessary for two reasons:+--+-- 1. If during the normal update process we notice that the root info was+--    updated (because the hash of @root.json@ in the new snapshot is different+--    from the old snapshot) we download new root info and start over, without+--    (yet) downloading a (potential) new index. This means it is important that+--    we not overwrite our local cached snapshot, because if we did we would+--    then on the next iteration conclude there were no updates and we would+--    fail to notice that we should have updated the index. However, unless we+--    do something, this means that we would conclude on the next iteration once+--    again that the root info has changed (because the hash in the new shapshot+--    still doesn't match the hash in the cached snapshot), and we would loop+--    until we throw a 'VerificationErrorLoop' exception. By deleting the local+--    snapshot we basically reset the client to its initial state, and we will+--    not try to download the root info once again. The only downside of this is+--    that we will also re-download the index after every root info change.+--    However, this should be infrequent enough that this isn't an issue.+--    See also <https://github.com/theupdateframework/tuf/issues/285>.+--+-- 2. Additionally, deleting the local timestamp and snapshot protects against+--    an attack where an attacker has set the file version of the snapshot or+--    timestamp to MAX_INT, thereby making further updates impossible.+--    (Such an attack would require a timestamp/snapshot key compromise.)+--+-- However, we _ONLY_ do this when the root information has actually changed.+-- If we did this unconditionally it would mean that we delete the locally+-- cached timestamp whenever the version on the remote timestamp is invalid,+-- thereby rendering the file version on the timestamp and the snapshot useless.+-- See <https://github.com/theupdateframework/tuf/issues/283#issuecomment-115739521>+updateRoot :: (Throws VerificationError, Throws SomeRemoteError)+           => Repository down+           -> Maybe UTCTime+           -> AttemptNr+           -> CachedInfo+           -> Either VerificationError (Trusted FileInfo)+           -> IO ()+updateRoot rep@Repository{..} mNow isRetry cachedInfo eFileInfo = do+    rootReallyChanged <- runVerify repLockCache $ do+      (_newRoot :: Trusted Root, rootTempFile) <- getRemoteFile+        rep+        cachedInfo+        isRetry+        mNow+        (RemoteRoot (eitherToMaybe eFileInfo))++      -- NOTE: It is important that we do this check within the evalContT,+      -- because the temporary file will be deleted once we leave its scope.+      case eFileInfo of+        Right _ ->+          -- We are downloading the root info because the hash in the snapshot+          -- changed. In this case the root definitely changed.+          return True+        Left _e -> liftIO $ do+          -- We are downloading the root because of a verification error. In+          -- this case the root info may or may not have changed. In most cases+          -- it would suffice to compare the file version now; however, in the+          -- (exceptional) circumstance where the root info has changed but+          -- the file version has not, this would result in the same infinite+          -- loop described above. Hence, we must compare file hashes, and they+          -- must be computed on the raw file, not the parsed file.+          oldRootFile <- repGetCachedRoot+          oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile+          not <$> downloadedVerify rootTempFile oldRootInfo++    when rootReallyChanged $ clearCache rep++{-------------------------------------------------------------------------------+  Convenience functions for downloading and parsing various files+-------------------------------------------------------------------------------}++data CachedInfo = CachedInfo {+    cachedRoot         :: Trusted Root+  , cachedKeyEnv       :: KeyEnv+  , cachedTimestamp    :: Maybe (Trusted Timestamp)+  , cachedSnapshot     :: Maybe (Trusted Snapshot)+  , cachedMirrors      :: Maybe (Trusted Mirrors)+  , cachedInfoSnapshot :: Maybe (Trusted FileInfo)+  , cachedInfoRoot     :: Maybe (Trusted FileInfo)+  , cachedInfoMirrors  :: Maybe (Trusted FileInfo)+  , cachedInfoTarGz    :: Maybe (Trusted FileInfo)+  }++cachedVersion :: CachedInfo -> RemoteFile fs typ -> Maybe FileVersion+cachedVersion CachedInfo{..} remoteFile =+    case mustCache remoteFile of+      CacheAs CachedTimestamp -> timestampVersion . trusted <$> cachedTimestamp+      CacheAs CachedSnapshot  -> snapshotVersion  . trusted <$> cachedSnapshot+      CacheAs CachedMirrors   -> mirrorsVersion   . trusted <$> cachedMirrors+      CacheAs CachedRoot      -> Just . rootVersion . trusted $ cachedRoot+      CacheIndex -> Nothing+      DontCache  -> Nothing++-- | Get all cached info (if any)+getCachedInfo :: (Applicative m, MonadIO m) => Repository down -> m CachedInfo+getCachedInfo rep = do+    (cachedRoot, cachedKeyEnv) <- readLocalRoot rep+    cachedTimestamp <- readLocalFile rep cachedKeyEnv CachedTimestamp+    cachedSnapshot  <- readLocalFile rep cachedKeyEnv CachedSnapshot+    cachedMirrors   <- readLocalFile rep cachedKeyEnv CachedMirrors++    let cachedInfoSnapshot = fmap (static timestampInfoSnapshot <$$>) cachedTimestamp+        cachedInfoRoot     = fmap (static snapshotInfoRoot      <$$>) cachedSnapshot+        cachedInfoMirrors  = fmap (static snapshotInfoMirrors   <$$>) cachedSnapshot+        cachedInfoTarGz    = fmap (static snapshotInfoTarGz     <$$>) cachedSnapshot++    return CachedInfo{..}++readLocalRoot :: MonadIO m => Repository down -> m (Trusted Root, KeyEnv)+readLocalRoot rep = do+    cachedPath <- liftIO $ repGetCachedRoot rep+    signedRoot <- throwErrorsUnchecked LocalFileCorrupted =<<+                    readCachedJSON rep KeyEnv.empty cachedPath+    return (trustLocalFile signedRoot, rootKeys (signed signedRoot))++readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a)+                 , MonadIO m, Applicative m+                 )+              => Repository down -> KeyEnv -> CachedFile -> m (Maybe (Trusted a))+readLocalFile rep cachedKeyEnv file = do+    mCachedPath <- liftIO $ repGetCached rep file+    for mCachedPath $ \cachedPath -> do+      signed <- throwErrorsUnchecked LocalFileCorrupted =<<+                  readCachedJSON rep cachedKeyEnv cachedPath+      return $ trustLocalFile signed++getRemoteFile :: ( Throws VerificationError+                 , Throws SomeRemoteError+                 , VerifyRole a+                 , FromJSON ReadJSON_Keys_Layout (Signed a)+                 )+              => Repository down+              -> CachedInfo+              -> AttemptNr+              -> Maybe UTCTime+              -> RemoteFile (f :- ()) Metadata+              -> Verify (Trusted a, down Metadata)+getRemoteFile rep@Repository{..} cachedInfo@CachedInfo{..} isRetry mNow file = do+    (targetPath, tempPath) <- getRemote' rep isRetry file+    verifyFileInfo' (remoteFileDefaultInfo file) targetPath tempPath+    signed   <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<<+                  readDownloadedJSON rep cachedKeyEnv tempPath+    verified <- throwErrorsChecked id $ verifyRole+                  cachedRoot+                  targetPath+                  (cachedVersion cachedInfo file)+                  mNow+                  signed+    return (trustVerified verified, tempPath)++{-------------------------------------------------------------------------------+  Downloading target files+-------------------------------------------------------------------------------}++-- | Download a package+downloadPackage :: ( Throws SomeRemoteError+                   , Throws VerificationError+                   , Throws InvalidPackageException+                   )+                => Repository down    -- ^ Repository+                -> PackageIdentifier  -- ^ Package to download+                -> Path Absolute      -- ^ Destination (see also 'downloadPackage'')+                -> IO ()+downloadPackage rep@Repository{..} pkgId dest =+    withMirror rep $+      withIndex rep $ \IndexCallbacks{..} -> runVerify repLockCache $ do+        -- Get the metadata (from the previously updated index)+        targetFileInfo <- liftIO $ indexLookupFileInfo pkgId++        -- TODO: should we check if cached package available? (spec says no)+        tarGz <- do+          (targetPath, downloaded) <- getRemote' rep (AttemptNr 0) $+            RemotePkgTarGz pkgId targetFileInfo+          verifyFileInfo' (Just targetFileInfo) targetPath downloaded+          return downloaded++        -- If all checks succeed, copy file to its target location.+        liftIO $ downloadedCopyTo tarGz dest++-- | Variation on 'downloadPackage' that takes a FilePath instead.+downloadPackage' :: ( Throws SomeRemoteError+                    , Throws VerificationError+                    , Throws InvalidPackageException+                    )+                 => Repository down    -- ^ Repository+                 -> PackageIdentifier  -- ^ Package to download+                 -> FilePath           -- ^ Destination+                 -> IO ()+downloadPackage' rep pkgId dest =+    downloadPackage rep pkgId =<< makeAbsolute (fromFilePath dest)++{-------------------------------------------------------------------------------+  Access to the tar index (the API is exported and used internally)++  NOTE: The files inside the index as evaluated lazily.++  1. The index tarball contains delegated target.json files for both unsigned+     and signed packages. We need to verify the signatures of all signed+     metadata (that is: the metadata for signed packages).++  2. Since the tarball also contains the .cabal files, we should also verify the+     hashes of those .cabal files against the hashes recorded in signed metadata+     (there is no point comparing against hashes recorded in unsigned metadata+     because attackers could just change those).++  Since we don't have author signing yet, we don't have any additional signed+  metadata and therefore we currently don't have to do anything here.++  TODO: If we have explicit, author-signed, lists of versions for a package (as+  described in @README.md@), then evaluating these "middle-level" delegation+  files lazily opens us up to a rollback attack: if we've never downloaded the+  delegations for a package before, then we have nothing to compare the version+  number in the file that we downloaded against. One option is to always+  download and verify all these middle level files (strictly); other is to+  include the version number of all of these files in the snapshot. This is+  described in more detail in+  <https://github.com/theupdateframework/tuf/issues/282#issuecomment-102468421>.++  TODO: Currently we hardcode the location of the package specific metadata. By+  rights we should read the global targets file and apply the delegation rules.+  Until we have author signing however this is unnecessary.+-------------------------------------------------------------------------------}++-- | Index directory+data Directory = Directory {+    -- | The first entry in the dictionary+    directoryFirst :: DirectoryEntry++    -- | The next available (i.e., one after last) directory entry+  , directoryNext :: DirectoryEntry++    -- | Lookup an entry in the dictionary+    --+    -- This is an efficient operation.+  , directoryLookup :: forall dec. IndexFile dec -> Maybe DirectoryEntry++    -- | An enumeration of all entries+    --+    -- This field is lazily constructed, so if you don't need it, it does not+    -- incur a performance overhead. Moreover, the 'IndexFile' is also created+    -- lazily so if you only need the raw 'IndexPath' there is no parsing+    -- overhead.+    --+    -- The entries are ordered by 'DirectoryEntry' so that the entries can+    -- efficiently be read in sequence.+    --+    -- NOTE: This means that there are two ways to enumerate all entries in the+    -- tar file, since when lookup an entry using 'indexLookupEntry' the+    -- 'DirectoryEntry' of the next entry is also returned. However, this+    -- involves reading through the entire @tar@ file. If you only need to read+    -- /some/ files, it is significantly more efficient to enumerate the tar+    -- entries using 'directoryEntries' instead and only call 'indexLookupEntry'+    -- when required.+  , directoryEntries :: [(DirectoryEntry, IndexPath, Maybe (Some IndexFile))]+  }++-- | Entry into the Hackage index.+newtype DirectoryEntry = DirectoryEntry {+    -- | (Low-level) block number of the tar index entry+    --+    -- Exposed for the benefit of clients who read the @.tar@ file directly.+    -- For this reason also the 'Show' and 'Read' instances for 'DirectoryEntry'+    -- just print and parse the underlying 'TarEntryOffset'.+    directoryEntryBlockNo :: Tar.TarEntryOffset+  }+  deriving (Eq, Ord)++instance Show DirectoryEntry where+  show = show . directoryEntryBlockNo++instance Read DirectoryEntry where+  readsPrec p = map (first DirectoryEntry) . readsPrec p++-- | Read the Hackage index directory+--+-- Should only be called after 'checkForUpdates'.+getDirectory :: Repository down -> IO Directory+getDirectory Repository{..} = mkDirectory <$> repGetIndexIdx+  where+    mkDirectory :: Tar.TarIndex -> Directory+    mkDirectory idx = Directory {+        directoryFirst   = DirectoryEntry 0+      , directoryNext    = DirectoryEntry $ Tar.indexEndEntryOffset idx+      , directoryLookup  = liftM dirEntry . Tar.lookup idx . filePath+      , directoryEntries = map mkEntry $ sortBy (comparing snd) (Tar.toList idx)+      }++    mkEntry :: (FilePath, Tar.TarEntryOffset)+            -> (DirectoryEntry, IndexPath, Maybe (Some IndexFile))+    mkEntry (fp, off) = (DirectoryEntry off, path, indexFile path)+      where+        path = indexPath fp++    dirEntry :: Tar.TarIndexEntry -> DirectoryEntry+    dirEntry (Tar.TarFileEntry offset) = DirectoryEntry offset+    dirEntry (Tar.TarDir _) = error "directoryLookup: unexpected directory"++    indexFile :: IndexPath -> Maybe (Some IndexFile)+    indexFile = indexFileFromPath repIndexLayout++    indexPath :: FilePath -> IndexPath+    indexPath = rootPath . fromUnrootedFilePath++    filePath :: IndexFile dec -> FilePath+    filePath = toUnrootedFilePath . unrootPath . indexFileToPath repIndexLayout++-- | Entry from the Hackage index; see 'withIndex'.+data IndexEntry dec = IndexEntry {+    -- | The raw path in the tarfile+    indexEntryPath :: IndexPath++    -- | The parsed file (if recognised)+  , indexEntryPathParsed :: Maybe (IndexFile dec)++    -- | The raw contents+    --+    -- Although this is a lazy bytestring, this is actually read into memory+    -- strictly (i.e., it can safely be used outside the scope of withIndex and+    -- friends).+  , indexEntryContent :: BS.L.ByteString++    -- | The parsed contents+    --+    -- This field is lazily constructed; the parser is not unless you do a+    -- pattern match on this value.+  , indexEntryContentParsed :: Either SomeException dec++    -- | The time of the entry in the tarfile.+  , indexEntryTime :: Tar.EpochTime+  }++-- | Various operations that we can perform on the index once its open+--+-- Note that 'IndexEntry' contains a fields both for the raw file contents and+-- the parsed file contents; clients can choose which to use.+--+-- In principle these callbacks will do verification (once we have implemented+-- author signing). Right now they don't need to do that, because the index as a+-- whole will have been verified.+data IndexCallbacks = IndexCallbacks {+    -- | Look up an entry by 'DirectoryEntry'+    --+    -- Since these 'DirectoryEntry's must come from somewhere (probably from the+    -- 'Directory'), it is assumed that they are valid; if they are not, an+    -- (unchecked) exception will be thrown.+    --+    -- This function also returns the 'DirectoryEntry' of the /next/ file in the+    -- index (if any) for the benefit of clients who wish to walk through the+    -- entire index.+    indexLookupEntry :: DirectoryEntry+                     -> IO (Some IndexEntry, Maybe DirectoryEntry)++    -- | Look up an entry by 'IndexFile'+    --+    -- Returns 'Nothing' if the 'IndexFile' does not refer to an existing file.+  , indexLookupFile :: forall dec.+                       IndexFile dec+                    -> IO (Maybe (IndexEntry dec))++    -- | Variation if both the 'DirectoryEntry' and the 'IndexFile' are known+    --+    -- You might use this when scanning the index using 'directoryEntries'.+  , indexLookupFileEntry :: forall dec.+                            DirectoryEntry+                         -> IndexFile dec+                         -> IO (IndexEntry dec)++    -- | Get (raw) cabal file (wrapper around 'indexLookupFile')+  , indexLookupCabal :: Throws InvalidPackageException+                     => PackageIdentifier+                     -> IO (Trusted BS.L.ByteString)++    -- | Lookup package metadata (wrapper around 'indexLookupFile')+    --+    -- This will throw an (unchecked) exception if the @targets.json@ file+    -- could not be parsed.+  , indexLookupMetadata :: Throws InvalidPackageException+                        => PackageIdentifier+                        -> IO (Trusted Targets)++    -- | Get file info (including hash) (wrapper around 'indexLookupFile')+  , indexLookupFileInfo :: ( Throws InvalidPackageException+                           , Throws VerificationError+                           )+                        => PackageIdentifier+                        -> IO (Trusted FileInfo)++    -- | Get the SHA256 hash for a package (wrapper around 'indexLookupInfo')+    --+    -- In addition to the exceptions thrown by 'indexLookupInfo', this will also+    -- throw an exception if the SHA256 is not listed in the 'FileMap' (again,+    -- this will not happen with a well-formed Hackage index.)+  , indexLookupHash :: ( Throws InvalidPackageException+                       , Throws VerificationError+                       )+                    => PackageIdentifier+                    -> IO (Trusted Hash)++    -- | The 'Directory' for the index+    --+    -- We provide this here because 'withIndex' will have read this anyway.+  , indexDirectory :: Directory+  }++-- | Look up entries in the Hackage index+--+-- This is in 'withFile' style so that clients can efficiently look up multiple+-- files from the index.+--+-- Should only be called after 'checkForUpdates'.+withIndex :: Repository down -> (IndexCallbacks -> IO a) -> IO a+withIndex rep@Repository{..} callback = do+    -- We need the cached root information in order to resolve key IDs and+    -- verify signatures. Note that whenever we read a JSON file, we verify+    -- signatures (even if we don't verify the keys); if this is a problem+    -- (for performance) we need to parameterize parseJSON.+    (_cachedRoot, keyEnv) <- readLocalRoot rep++    -- We need the directory to resolve 'IndexFile's and to know the index of+    -- the last entry.+    dir@Directory{..} <- getDirectory rep++    -- Open the index+    repWithIndex $ \h -> do+      let getEntry :: DirectoryEntry+                   -> IO (Some IndexEntry, Maybe DirectoryEntry)+          getEntry entry = do+            (tarEntry, content, next) <- getTarEntry entry+            let path = indexPath tarEntry+            case indexFile path of+              Nothing ->+                return (Some (mkEntry tarEntry content Nothing), next)+              Just (Some file) ->+                return (Some (mkEntry tarEntry content (Just file)), next)++          getFile :: IndexFile dec -> IO (Maybe (IndexEntry dec))+          getFile file =+            case directoryLookup file of+              Nothing       -> return Nothing+              Just dirEntry -> Just <$> getFileEntry dirEntry file++          getFileEntry :: DirectoryEntry+                       -> IndexFile dec+                       -> IO (IndexEntry dec)+          getFileEntry dirEntry file = do+            (tarEntry, content, _next) <- getTarEntry dirEntry+            return $ mkEntry tarEntry content (Just file)++          mkEntry :: Tar.Entry+                  -> BS.L.ByteString+                  -> Maybe (IndexFile dec)+                  -> IndexEntry dec+          mkEntry tarEntry content mFile = IndexEntry {+              indexEntryPath          = indexPath tarEntry+            , indexEntryPathParsed    = mFile+            , indexEntryContent       = content+            , indexEntryContentParsed = parseContent mFile content+            , indexEntryTime          = Tar.entryTime tarEntry+            }++          parseContent :: Maybe (IndexFile dec)+                       -> BS.L.ByteString -> Either SomeException dec+          parseContent Nothing     _   = Left pathNotRecognized+          parseContent (Just file) raw = case file of+            IndexPkgPrefs _ ->+              Right () -- We don't currently parse preference files+            IndexPkgCabal _ ->+              Right () -- We don't currently parse .cabal files+            IndexPkgMetadata _ ->+              let mkEx = either+                           (Left . SomeException . InvalidFileInIndex file raw)+                           Right+              in mkEx $ parseJSON_Keys_NoLayout keyEnv raw++          -- Read an entry from the tar file. Returns entry content separately,+          -- throwing an exception if the entry is not a regular file.+          -- Also throws an exception if the 'DirectoryEntry' is invalid.+          getTarEntry :: DirectoryEntry+                      -> IO (Tar.Entry, BS.L.ByteString, Maybe DirectoryEntry)+          getTarEntry (DirectoryEntry offset) = do+            entry   <- Tar.hReadEntry h offset+            content <- case Tar.entryContent entry of+                         Tar.NormalFile content _sz -> return content+                         _ -> throwIO $ userError "withIndex: unexpected entry"+            let next  = DirectoryEntry $ Tar.nextEntryOffset entry offset+                mNext = guard (next < directoryNext) >> return next+            return (entry, content, mNext)++          -- Get cabal file+          getCabal :: Throws InvalidPackageException+                   => PackageIdentifier -> IO (Trusted BS.L.ByteString)+          getCabal pkgId = do+            mCabal <- getFile $ IndexPkgCabal pkgId+            case mCabal of+              Nothing ->+                throwChecked $ InvalidPackageException pkgId+              Just IndexEntry{..} ->+                return $ DeclareTrusted indexEntryContent++          -- Get package metadata+          getMetadata :: Throws InvalidPackageException+                      => PackageIdentifier -> IO (Trusted Targets)+          getMetadata pkgId = do+            mEntry <- getFile $ IndexPkgMetadata pkgId+            case mEntry of+              Nothing ->+                throwChecked $ InvalidPackageException pkgId+              Just IndexEntry{indexEntryContentParsed = Left ex} ->+                throwUnchecked $ ex+              Just IndexEntry{indexEntryContentParsed = Right signed} ->+                return $ trustLocalFile signed++          -- Get package info+          getFileInfo :: ( Throws InvalidPackageException+                         , Throws VerificationError+                         )+                      => PackageIdentifier -> IO (Trusted FileInfo)+          getFileInfo pkgId = do+            targets <- getMetadata pkgId++            let mTargetMetadata :: Maybe (Trusted FileInfo)+                mTargetMetadata = trustElems+                                $ trustStatic (static targetsLookup)+                     `trustApply` DeclareTrusted (targetPath pkgId)+                     `trustApply` targets++            case mTargetMetadata of+              Nothing ->+                throwChecked $ VerificationErrorUnknownTarget (targetPath pkgId)+              Just info ->+                return info++          -- Get package SHA256+          getHash :: ( Throws InvalidPackageException+                     , Throws VerificationError+                     )+                  => PackageIdentifier -> IO (Trusted Hash)+          getHash pkgId = do+            info <- getFileInfo pkgId++            let mTrustedHash :: Maybe (Trusted Hash)+                mTrustedHash = trustElems+                             $ trustStatic (static fileInfoSHA256)+                  `trustApply` info++            case mTrustedHash of+              Nothing ->+                throwChecked $ VerificationErrorMissingSHA256 (targetPath pkgId)+              Just hash ->+                return hash++      callback IndexCallbacks{+          indexLookupEntry     = getEntry+        , indexLookupFile      = getFile+        , indexLookupFileEntry = getFileEntry+        , indexDirectory       = dir+        , indexLookupCabal     = getCabal+        , indexLookupMetadata  = getMetadata+        , indexLookupFileInfo  = getFileInfo+        , indexLookupHash      = getHash+        }+  where+    indexPath :: Tar.Entry -> IndexPath+    indexPath = rootPath . fromUnrootedFilePath . Tar.entryPath++    indexFile :: IndexPath -> Maybe (Some IndexFile)+    indexFile = indexFileFromPath repIndexLayout++    targetPath :: PackageIdentifier -> TargetPath+    targetPath = TargetPathRepo . repoLayoutPkgTarGz repLayout++    pathNotRecognized :: SomeException+    pathNotRecognized = SomeException (userError "Path not recognized")++{-------------------------------------------------------------------------------+  Bootstrapping+-------------------------------------------------------------------------------}++-- | Check if we need to bootstrap (i.e., if we have root info)+requiresBootstrap :: Repository down -> IO Bool+requiresBootstrap rep = isNothing <$> repGetCached rep CachedRoot++-- | Bootstrap the chain of trust+--+-- New clients might need to obtain a copy of the root metadata. This however+-- represents a chicken-and-egg problem: how can we verify the root metadata+-- we downloaded? The only possibility is to be provided with a set of an+-- out-of-band set of root keys and an appropriate threshold.+--+-- Clients who provide a threshold of 0 can do an initial "unsafe" update+-- of the root information, if they wish.+--+-- The downloaded root information will _only_ be verified against the+-- provided keys, and _not_ against previously downloaded root info (if any).+-- It is the responsibility of the client to call `bootstrap` only when this+-- is the desired behaviour.+bootstrap :: (Throws SomeRemoteError, Throws VerificationError)+          => Repository down -> [KeyId] -> KeyThreshold -> IO ()+bootstrap rep@Repository{..} trustedRootKeys keyThreshold = withMirror rep $ runVerify repLockCache $ do+    _newRoot :: Trusted Root <- do+      (targetPath, tempPath) <- getRemote' rep (AttemptNr 0) (RemoteRoot Nothing)+      signed   <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<<+                    readDownloadedJSON rep KeyEnv.empty tempPath+      verified <- throwErrorsChecked id $ verifyFingerprints+                    trustedRootKeys+                    keyThreshold+                    targetPath+                    signed+      return $ trustVerified verified++    clearCache rep++{-------------------------------------------------------------------------------+  Wrapper around the Repository functions+-------------------------------------------------------------------------------}++getRemote :: forall fs down typ. Throws SomeRemoteError+          => Repository down+          -> AttemptNr+          -> RemoteFile fs typ+          -> Verify (Some Format, TargetPath, down typ)+getRemote r attemptNr file = do+    (Some format, downloaded) <- repGetRemote r attemptNr file+    let targetPath = TargetPathRepo $ remoteRepoPath' (repLayout r) file format+    return (Some (hasFormatGet format), targetPath, downloaded)++-- | Variation on getRemote where we only expect one type of result+getRemote' :: forall f down typ. Throws SomeRemoteError+           => Repository down+           -> AttemptNr+           -> RemoteFile (f :- ()) typ+           -> Verify (TargetPath, down typ)+getRemote' r isRetry file = ignoreFormat <$> getRemote r isRetry file+  where+    ignoreFormat (_format, targetPath, tempPath) = (targetPath, tempPath)++clearCache :: MonadIO m => Repository down -> m ()+clearCache r = liftIO $ repClearCache r++log :: MonadIO m => Repository down -> LogMessage -> m ()+log r msg = liftIO $ repLog r msg++-- Tries to load the cached mirrors file+withMirror :: Repository down -> IO a -> IO a+withMirror rep callback = do+    mMirrors <- repGetCached rep CachedMirrors+    mirrors  <- case mMirrors of+      Nothing -> return Nothing+      Just fp -> filterMirrors <$>+                   (throwErrorsUnchecked LocalFileCorrupted =<<+                     readJSON_NoKeys_NoLayout fp)+    repWithMirror rep mirrors $ callback+  where+    filterMirrors :: UninterpretedSignatures Mirrors -> Maybe [Mirror]+    filterMirrors = Just+                  . filter (canUseMirror . mirrorContent)+                  . mirrorsMirrors+                  . uninterpretedSigned++    -- Once we add support for partial mirrors, we wil need an additional+    -- argument to 'repWithMirror' (here, not in the Repository API itself)+    -- that tells us which files we will be requested from the mirror.+    -- We can then compare that against the specification of the partial mirror+    -- to see if all of those files are available from this mirror.+    canUseMirror :: MirrorContent -> Bool+    canUseMirror MirrorFull = True++{-------------------------------------------------------------------------------+  Exceptions+-------------------------------------------------------------------------------}++-- | Re-throw all exceptions thrown by the client API as unchecked exceptions+uncheckClientErrors :: ( ( Throws VerificationError+                         , Throws SomeRemoteError+                         , Throws InvalidPackageException+                         ) => IO a )+                     -> IO a+uncheckClientErrors act = handleChecked rethrowVerificationError+                        $ handleChecked rethrowSomeRemoteError+                        $ handleChecked rethrowInvalidPackageException+                        $ act+  where+     rethrowVerificationError :: VerificationError -> IO a+     rethrowVerificationError = throwIO++     rethrowSomeRemoteError :: SomeRemoteError -> IO a+     rethrowSomeRemoteError = throwIO++     rethrowInvalidPackageException :: InvalidPackageException -> IO a+     rethrowInvalidPackageException = throwIO++data InvalidPackageException = InvalidPackageException PackageIdentifier+  deriving (Typeable)++data LocalFileCorrupted = LocalFileCorrupted DeserializationError+  deriving (Typeable)++data InvalidFileInIndex = forall dec. InvalidFileInIndex {+    invalidFileInIndex      :: IndexFile dec+  , invalidFileInIndexRaw   :: BS.L.ByteString+  , invalidFileInIndexError :: DeserializationError+  }+  deriving (Typeable)++#if MIN_VERSION_base(4,8,0)+deriving instance Show InvalidPackageException+deriving instance Show LocalFileCorrupted+deriving instance Show InvalidFileInIndex+instance Exception InvalidPackageException where displayException = pretty+instance Exception LocalFileCorrupted where displayException = pretty+instance Exception InvalidFileInIndex where displayException = pretty+#else+instance Show InvalidPackageException where show = pretty+instance Show LocalFileCorrupted where show = pretty+instance Show InvalidFileInIndex where show = pretty+instance Exception InvalidPackageException+instance Exception LocalFileCorrupted+instance Exception InvalidFileInIndex+#endif++instance Pretty InvalidPackageException where+  pretty (InvalidPackageException pkgId) = "Invalid package " ++ display pkgId++instance Pretty LocalFileCorrupted where+  pretty (LocalFileCorrupted err) = "Local file corrupted: " ++ pretty err++instance Pretty InvalidFileInIndex where+  pretty (InvalidFileInIndex file raw err) = unlines [+      "Invalid file in index: "  ++ pretty file+    , "Error: " ++ pretty err+    , "Unparsed file: " ++ BS.L.C8.unpack raw+    ]++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Local files are assumed trusted+--+-- There is no point tracking chain of trust for local files because that chain+-- would necessarily have to start at an implicitly trusted (though unverified)+-- file: the root metadata.+trustLocalFile :: Signed a -> Trusted a+trustLocalFile Signed{..} = DeclareTrusted signed++-- | Just a simple wrapper around 'verifyFileInfo'+--+-- Throws a VerificationError if verification failed.+verifyFileInfo' :: (MonadIO m, DownloadedFile down)+                => Maybe (Trusted FileInfo)+                -> TargetPath  -- ^ For error messages+                -> down typ    -- ^ File to verify+                -> m ()+verifyFileInfo' Nothing     _          _        = return ()+verifyFileInfo' (Just info) targetPath tempPath = liftIO $ do+    verified <- downloadedVerify tempPath info+    unless verified $ throw $ VerificationErrorFileInfo targetPath++readCachedJSON :: (MonadIO m, FromJSON ReadJSON_Keys_Layout a)+               => Repository down -> KeyEnv -> Path Absolute+               -> m (Either DeserializationError a)+readCachedJSON Repository{..} keyEnv fp = liftIO $ do+    bs <- readLazyByteString fp+    evaluate $ parseJSON_Keys_Layout keyEnv repLayout bs++readDownloadedJSON :: (MonadIO m, FromJSON ReadJSON_Keys_Layout a)+                   => Repository down -> KeyEnv -> down Metadata+                   -> m (Either DeserializationError a)+readDownloadedJSON Repository{..} keyEnv fp = liftIO $ do+    bs <- downloadedRead fp+    evaluate $ parseJSON_Keys_Layout keyEnv repLayout bs++throwErrorsUnchecked :: ( MonadIO m+                        , Exception e'+                        )+                     => (e -> e') -> Either e a -> m a+throwErrorsUnchecked f (Left err) = liftIO $ throwUnchecked (f err)+throwErrorsUnchecked _ (Right a)  = return a++throwErrorsChecked :: ( Throws e'+                      , MonadIO m+                      , Exception e'+                      )+                   => (e -> e') -> Either e a -> m a+throwErrorsChecked f (Left err) = liftIO $ throwChecked (f err)+throwErrorsChecked _ (Right a)  = return a++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left  _) = Nothing+eitherToMaybe (Right b) = Just b
+ hackage-security/hackage-security/src/Hackage/Security/Client/Formats.hs view
@@ -0,0 +1,116 @@+module Hackage.Security.Client.Formats (+    -- * Formats+    -- ** Type level+    FormatUn+  , FormatGz+    -- ** Term level+  , Format(..)+  , Formats(..)+    -- * Key membership+  , HasFormat(..)+    -- ** Utility+  , hasFormatAbsurd+  , hasFormatGet+    -- * Map-like operations+  , formatsMap+  , formatsMember+  , formatsLookup+  ) where++import Hackage.Security.Util.Stack+import Hackage.Security.Util.TypedEmbedded++{-------------------------------------------------------------------------------+  Formats+-------------------------------------------------------------------------------}++data FormatUn+data FormatGz++-- | Format is a singleton type (reflection type to term level)+--+-- NOTE: In the future we might add further compression formats.+data Format :: * -> * where+  FUn :: Format FormatUn+  FGz :: Format FormatGz++deriving instance Show (Format f)+deriving instance Eq   (Format f)++instance Unify Format where+  unify FUn FUn = Just Refl+  unify FGz FGz = Just Refl+  unify _   _   = Nothing++{-------------------------------------------------------------------------------+  Products+-------------------------------------------------------------------------------}++-- | Available formats+--+-- Rather than having a general list here, we enumerate all possibilities.+-- This means we are very precise about what we expect, and we avoid any runtime+-- errors about unexpect format definitions.+--+-- NOTE: If we add additional cases here (for dealing with additional formats)+-- all calls to @error "inaccessible"@ need to be reevaluated.+data Formats :: * -> * -> * where+  FsNone :: Formats () a+  FsUn   :: a -> Formats (FormatUn :- ()) a+  FsGz   :: a -> Formats (FormatGz :- ()) a+  FsUnGz :: a -> a -> Formats (FormatUn :- FormatGz :- ()) a++deriving instance Eq   a => Eq   (Formats fs a)+deriving instance Show a => Show (Formats fs a)++instance Functor (Formats fs) where+  fmap g = formatsMap (\_format -> g)++{-------------------------------------------------------------------------------+  Key membership+-------------------------------------------------------------------------------}++-- | @HasFormat fs f@ is a proof that @f@ is a key in @fs@.+--+-- See 'formatsMember' and 'formatsLookup' for typical usage.+data HasFormat :: * -> * -> * where+  HFZ :: Format f       -> HasFormat (f  :- fs) f+  HFS :: HasFormat fs f -> HasFormat (f' :- fs) f++deriving instance Eq   (HasFormat fs f)+deriving instance Show (HasFormat fs f)++hasFormatAbsurd :: HasFormat () f -> a+hasFormatAbsurd _ = error "inaccessible"++hasFormatGet :: HasFormat fs f -> Format f+hasFormatGet (HFZ f)  = f+hasFormatGet (HFS hf) = hasFormatGet hf++{-------------------------------------------------------------------------------+  Map-like functionality+-------------------------------------------------------------------------------}++formatsMap :: (forall f. Format f -> a -> b) -> Formats fs a -> Formats fs b+formatsMap _ FsNone        = FsNone+formatsMap f (FsUn   a)    = FsUn   (f FUn a)+formatsMap f (FsGz   a)    = FsGz   (f FGz a)+formatsMap f (FsUnGz a a') = FsUnGz (f FUn a) (f FGz a')++formatsMember :: Format f -> Formats fs a -> Maybe (HasFormat fs f)+formatsMember _   FsNone       = Nothing+formatsMember FUn (FsUn   _  ) = Just $ HFZ FUn+formatsMember FUn (FsGz     _) = Nothing+formatsMember FUn (FsUnGz _ _) = Just $ HFZ FUn+formatsMember FGz (FsUn   _  ) = Nothing+formatsMember FGz (FsGz     _) = Just $ HFZ FGz+formatsMember FGz (FsUnGz _ _) = Just $ HFS (HFZ FGz)++formatsLookup :: HasFormat fs f -> Formats fs a -> a+formatsLookup (HFZ FUn) (FsUn   a  ) = a+formatsLookup (HFZ FUn) (FsUnGz a _) = a+formatsLookup (HFZ FGz) (FsGz     a) = a+formatsLookup (HFS hf)  (FsUn   _  ) = hasFormatAbsurd hf+formatsLookup (HFS hf)  (FsGz     _) = hasFormatAbsurd hf+formatsLookup (HFS hf)  (FsUnGz _ a) = formatsLookup hf (FsGz a)+formatsLookup _         _            = error "inaccessible"
+ hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs view
@@ -0,0 +1,462 @@+-- | Abstract definition of a Repository+--+-- Most clients should only need to import this module if they wish to define+-- their own Repository implementations.+{-# LANGUAGE CPP #-}+module Hackage.Security.Client.Repository (+    -- * Files+    Metadata  -- type index (really a kind)+  , Binary    -- type index (really a kind)+  , RemoteFile(..)+  , CachedFile(..)+  , IndexFile(..)+  , remoteFileDefaultFormat+  , remoteFileDefaultInfo+    -- * Repository proper+  , Repository(..)+  , AttemptNr(..)+  , LogMessage(..)+  , UpdateFailure(..)+  , SomeRemoteError(..)+    -- ** Downloaded files+  , DownloadedFile(..)+    -- ** Helpers+  , mirrorsUnsupported+    -- * Paths+  , remoteRepoPath+  , remoteRepoPath'+    -- * Utility+  , IsCached(..)+  , mustCache+  ) where++import Control.Exception+import Data.Typeable (Typeable)+import qualified Codec.Archive.Tar.Index as Tar+import qualified Data.ByteString.Lazy    as BS.L++import Distribution.Package+import Distribution.Text++import Hackage.Security.Client.Formats+import Hackage.Security.Client.Verify+import Hackage.Security.Trusted+import Hackage.Security.TUF+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some+import Hackage.Security.Util.Stack++{-------------------------------------------------------------------------------+  Files+-------------------------------------------------------------------------------}++data Metadata+data Binary++-- | Abstract definition of files we might have to download+--+-- 'RemoteFile' is parametrized by the type of the formats that we can accept+-- from the remote repository, as well as with information on whether this file+-- is metadata actual binary content.+--+-- NOTE: Haddock lacks GADT support so constructors have only regular comments.+data RemoteFile :: * -> * -> * where+    -- Timestamp metadata (@timestamp.json@)+    --+    -- We never have (explicit) file length available for timestamps.+    RemoteTimestamp :: RemoteFile (FormatUn :- ()) Metadata++    -- Root metadata (@root.json@)+    --+    -- For root information we may or may not have the file info available:+    --+    -- - If during the normal update process the new snapshot tells us the root+    --   information has changed, we can use the file info from the snapshot.+    -- - If however we need to update the root metadata due to a verification+    --   exception we do not know the file info.+    -- - We also do not know the file info during bootstrapping.+    RemoteRoot :: Maybe (Trusted FileInfo) -> RemoteFile (FormatUn :- ()) Metadata++    -- Snapshot metadata (@snapshot.json@)+    --+    -- We get file info of the snapshot from the timestamp.+    RemoteSnapshot :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata++    -- Mirrors metadata (@mirrors.json@)+    --+    -- We get the file info from the snapshot.+    RemoteMirrors :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata++    -- Index+    --+    -- The index file length comes from the snapshot.+    --+    -- When we request that the index is downloaded, it is up to the repository+    -- to decide whether to download @00-index.tar@ or @00-index.tar.gz@.+    -- The callback is told which format was requested.+    --+    -- It is a bug to request a file that the repository does not provide+    -- (the snapshot should make it clear which files are available).+    RemoteIndex :: HasFormat fs FormatGz+                -> Formats fs (Trusted FileInfo)+                -> RemoteFile fs Binary++    -- Actual package+    --+    -- Package file length comes from the corresponding @targets.json@.+    RemotePkgTarGz :: PackageIdentifier+                   -> Trusted FileInfo+                   -> RemoteFile (FormatGz :- ()) Binary++deriving instance Show (RemoteFile fs typ)++instance Pretty (RemoteFile fs typ) where+  pretty RemoteTimestamp          = "timestamp"+  pretty (RemoteRoot _)           = "root"+  pretty (RemoteSnapshot _)       = "snapshot"+  pretty (RemoteMirrors _)        = "mirrors"+  pretty (RemoteIndex _ _)        = "index"+  pretty (RemotePkgTarGz pkgId _) = "package " ++ display pkgId++-- | Files that we might request from the local cache+data CachedFile =+    -- | Timestamp metadata (@timestamp.json@)+    CachedTimestamp++    -- | Root metadata (@root.json@)+  | CachedRoot++    -- | Snapshot metadata (@snapshot.json@)+  | CachedSnapshot++    -- | Mirrors list (@mirrors.json@)+  | CachedMirrors+  deriving (Eq, Ord, Show)++instance Pretty CachedFile where+  pretty CachedTimestamp = "timestamp"+  pretty CachedRoot      = "root"+  pretty CachedSnapshot  = "snapshot"+  pretty CachedMirrors   = "mirrors"++-- | Default format for each file type+--+-- For most file types we don't have a choice; for the index the repository+-- is only required to offer the GZip-compressed format so that is the default.+remoteFileDefaultFormat :: RemoteFile fs typ -> Some (HasFormat fs)+remoteFileDefaultFormat RemoteTimestamp      = Some $ HFZ FUn+remoteFileDefaultFormat (RemoteRoot _)       = Some $ HFZ FUn+remoteFileDefaultFormat (RemoteSnapshot _)   = Some $ HFZ FUn+remoteFileDefaultFormat (RemoteMirrors _)    = Some $ HFZ FUn+remoteFileDefaultFormat (RemotePkgTarGz _ _) = Some $ HFZ FGz+remoteFileDefaultFormat (RemoteIndex pf _)   = Some pf++-- | Default file info (see also 'remoteFileDefaultFormat')+remoteFileDefaultInfo :: RemoteFile fs typ -> Maybe (Trusted FileInfo)+remoteFileDefaultInfo RemoteTimestamp         = Nothing+remoteFileDefaultInfo (RemoteRoot info)       = info+remoteFileDefaultInfo (RemoteSnapshot info)   = Just info+remoteFileDefaultInfo (RemoteMirrors info)    = Just info+remoteFileDefaultInfo (RemotePkgTarGz _ info) = Just info+remoteFileDefaultInfo (RemoteIndex pf info)   = Just $ formatsLookup pf info++{-------------------------------------------------------------------------------+  Repository proper+-------------------------------------------------------------------------------}++-- | Repository+--+-- This is an abstract representation of a repository. It simply provides a way+-- to download metafiles and target files, without specifying how this is done.+-- For instance, for a local repository this could just be doing a file read,+-- whereas for remote repositories this could be using any kind of HTTP client.+data Repository down = DownloadedFile down => Repository {+    -- | Get a file from the server+    --+    -- Responsibilies of 'repGetRemote':+    --+    -- * Download the file from the repository and make it available at a+    --   temporary location+    -- * Use the provided file length to protect against endless data attacks.+    --   (Repositories such as local repositories that are not suspectible to+    --   endless data attacks can safely ignore this argument.)+    -- * Move the file from its temporary location to its permanent location+    --   if verification succeeds.+    --+    -- NOTE: Calls to 'repGetRemote' should _always_ be in the scope of+    -- 'repWithMirror'.+    repGetRemote :: forall fs typ. Throws SomeRemoteError+                 => AttemptNr+                 -> RemoteFile fs typ+                 -> Verify (Some (HasFormat fs), down typ)++    -- | Get a cached file (if available)+  , repGetCached :: CachedFile -> IO (Maybe (Path Absolute))++    -- | Get the cached root+    --+    -- This is a separate method only because clients must ALWAYS have root+    -- information available.+  , repGetCachedRoot :: IO (Path Absolute)++    -- | Clear all cached data+    --+    -- In particular, this should remove the snapshot and the timestamp.+    -- It would also be okay, but not required, to delete the index.+  , repClearCache :: IO ()++    -- | Open the tarball for reading+    --+    -- This function has this shape so that:+    --+    -- * We can read multiple files from the tarball without having to open+    --   and close the handle each time+    -- * We can close the handle immediately when done.+  , repWithIndex :: forall a. (Handle -> IO a) -> IO a++    -- | Read the index index+  , repGetIndexIdx :: IO Tar.TarIndex++    -- | Lock the cache (during updates)+  , repLockCache :: IO () -> IO ()++    -- | Mirror selection+    --+    -- The purpose of 'repWithMirror' is to scope mirror selection. The idea+    -- is that if we have+    --+    -- > repWithMirror mirrorList $+    -- >   someCallback+    --+    -- then the repository may pick a mirror before calling @someCallback@,+    -- catch exceptions thrown by @someCallback@, and potentially try the+    -- callback again with a different mirror.+    --+    -- The list of mirrors may be @Nothing@ if we haven't yet downloaded the+    -- list of mirrors from the repository, or when our cached list of mirrors+    -- is invalid. Of course, if we did download it, then the list of mirrors+    -- may still be empty. In this case the repository must fall back to its+    -- primary download mechanism.+    --+    -- Mirrors as currently defined (in terms of a "base URL") are inherently a+    -- HTTP (or related) concept, so in repository implementations such as the+    -- local-repo 'repWithMirrors' is probably just an identity operation  (see+    -- 'ignoreMirrors').  Conversely, HTTP implementations of repositories may+    -- have other, out-of-band information (for example, coming from a cabal+    -- config file) that they may use to influence mirror selection.+  , repWithMirror :: forall a. Maybe [Mirror] -> IO a -> IO a++    -- | Logging+  , repLog :: LogMessage -> IO ()++    -- | Layout of this repository+  , repLayout :: RepoLayout++    -- | Layout of the index+    --+    -- Since the repository hosts the index, the layout of the index is+    -- not independent of the layout of the repository.+  , repIndexLayout :: IndexLayout++    -- | Description of the repository (used in the show instance)+  , repDescription :: String+  }++instance Show (Repository down) where+  show = repDescription++-- | Helper function to implement 'repWithMirrors'.+mirrorsUnsupported :: Maybe [Mirror] -> IO a -> IO a+mirrorsUnsupported _ = id++-- | Are we requesting this information because of a previous validation error?+--+-- Clients can take advantage of this to tell caches to revalidate files.+newtype AttemptNr = AttemptNr Int+  deriving (Eq, Ord, Num)++-- | Log messages+--+-- We use a 'RemoteFile' rather than a 'RepoPath' here because we might not have+-- a 'RepoPath' for the file that we were trying to download (that is, for+-- example if the server does not provide an uncompressed tarball, it doesn't+-- make much sense to list the path to that non-existing uncompressed tarball).+data LogMessage =+    -- | Root information was updated+    --+    -- This message is issued when the root information is updated as part of+    -- the normal check for updates procedure. If the root information is+    -- updated because of a verification error WarningVerificationError is+    -- issued instead.+    LogRootUpdated++    -- | A verification error+    --+    -- Verification errors can be temporary, and may be resolved later; hence+    -- these are just warnings. (Verification errors that cannot be resolved+    -- are thrown as exceptions.)+  | LogVerificationError VerificationError++    -- | Download a file from a repository+  | forall fs typ. LogDownloading (RemoteFile fs typ)++    -- | Incrementally updating a file from a repository+  | forall fs. LogUpdating (RemoteFile fs Binary)++    -- | Selected a particular mirror+  | LogSelectedMirror MirrorDescription++    -- | Updating a file failed+    -- (we will instead download it whole)+  | forall fs. LogCannotUpdate (RemoteFile fs Binary) UpdateFailure++    -- | We got an exception with a particular mirror+    -- (we will try with a different mirror if any are available)+  | LogMirrorFailed MirrorDescription SomeException++-- | Records why we are downloading a file rather than updating it.+data UpdateFailure =+    -- | Server does not support incremental downloads+    UpdateImpossibleUnsupported++    -- | We don't have a local copy of the file to update+  | UpdateImpossibleNoLocalCopy++    -- | Update failed twice+    --+    -- If we attempt an incremental update the first time, and it fails,  we let+    -- it go round the loop, update local security information, and try again.+    -- But if an incremental update then fails _again_, we  instead attempt a+    -- regular download.+  | UpdateFailedTwice++    -- | Update failed (for example: perhaps the local file got corrupted)+  | UpdateFailed SomeException++{-------------------------------------------------------------------------------+  Downloaded files+-------------------------------------------------------------------------------}++class DownloadedFile (down :: * -> *) where+  -- | Verify a download file+  downloadedVerify :: down a -> Trusted FileInfo -> IO Bool++  -- | Read the file we just downloaded into memory+  --+  -- We never read binary data, only metadata.+  downloadedRead :: down Metadata -> IO BS.L.ByteString++  -- | Copy a downloaded file to its destination+  downloadedCopyTo :: down a -> Path Absolute -> IO ()++{-------------------------------------------------------------------------------+  Exceptions thrown by specific Repository implementations+-------------------------------------------------------------------------------}++-- | Repository-specific exceptions+--+-- For instance, for repositories using HTTP this might correspond to a 404;+-- for local repositories this might correspond to file-not-found, etc.+data SomeRemoteError :: * where+    SomeRemoteError :: Exception e => e -> SomeRemoteError+  deriving (Typeable)++#if MIN_VERSION_base(4,8,0)+deriving instance Show SomeRemoteError+instance Exception SomeRemoteError where displayException = pretty+#else+instance Exception SomeRemoteError+instance Show SomeRemoteError where show = pretty+#endif++instance Pretty SomeRemoteError where+    pretty (SomeRemoteError ex) = displayException ex++{-------------------------------------------------------------------------------+  Paths+-------------------------------------------------------------------------------}++remoteRepoPath :: RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath+remoteRepoPath RepoLayout{..} = go+  where+    go :: RemoteFile fs typ -> Formats fs RepoPath+    go RemoteTimestamp        = FsUn $ repoLayoutTimestamp+    go (RemoteRoot _)         = FsUn $ repoLayoutRoot+    go (RemoteSnapshot _)     = FsUn $ repoLayoutSnapshot+    go (RemoteMirrors _)      = FsUn $ repoLayoutMirrors+    go (RemotePkgTarGz pId _) = FsGz $ repoLayoutPkgTarGz pId+    go (RemoteIndex _ lens)   = formatsMap goIndex lens++    goIndex :: Format f -> a -> RepoPath+    goIndex FUn _ = repoLayoutIndexTar+    goIndex FGz _ = repoLayoutIndexTarGz++remoteRepoPath' :: RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath+remoteRepoPath' repoLayout file format =+    formatsLookup format $ remoteRepoPath repoLayout file++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++-- | Is a particular remote file cached?+data IsCached :: * -> * where+    -- | This remote file should be cached, and we ask for it by name+    CacheAs :: CachedFile -> IsCached Metadata++    -- | We don't cache this remote file+    --+    -- This doesn't mean a Repository should not feel free to cache the file+    -- if desired, but it does mean the generic algorithms will never ask for+    -- this file from the cache.+    DontCache :: IsCached Binary++    -- | The index is somewhat special: it should be cached, but we never+    -- ask for it directly.+    --+    -- Instead, we will ask the Repository for files _from_ the index, which it+    -- can serve however it likes. For instance, some repositories might keep+    -- the index in uncompressed form, others in compressed form; some might+    -- keep an index tarball index for quick access, others may scan the tarball+    -- linearly, etc.+    CacheIndex :: IsCached Binary++deriving instance Eq   (IsCached typ)+deriving instance Show (IsCached typ)++-- | Which remote files should we cache locally?+mustCache :: RemoteFile fs typ -> IsCached typ+mustCache RemoteTimestamp      = CacheAs CachedTimestamp+mustCache (RemoteRoot _)       = CacheAs CachedRoot+mustCache (RemoteSnapshot _)   = CacheAs CachedSnapshot+mustCache (RemoteMirrors _)    = CacheAs CachedMirrors+mustCache (RemoteIndex {})     = CacheIndex+mustCache (RemotePkgTarGz _ _) = DontCache++instance Pretty LogMessage where+  pretty LogRootUpdated =+      "Root info updated"+  pretty (LogVerificationError err) =+      "Verification error: " ++ pretty err+  pretty (LogDownloading file) =+      "Downloading " ++ pretty file+  pretty (LogUpdating file) =+      "Updating " ++ pretty file+  pretty (LogSelectedMirror mirror) =+      "Selected mirror " ++ mirror+  pretty (LogCannotUpdate file ex) =+      "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")"+  pretty (LogMirrorFailed mirror ex) =+      "Exception " ++ displayException ex ++ " when using mirror " ++ mirror++instance Pretty UpdateFailure where+  pretty UpdateImpossibleUnsupported =+      "server does not provide incremental downloads"+  pretty UpdateImpossibleNoLocalCopy =+      "no local copy"+  pretty UpdateFailedTwice =+      "update failed twice"+  pretty (UpdateFailed ex) =+      displayException ex
+ hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE BangPatterns #-}+-- | The files we cache from the repository+--+-- Both the Local and the Remote repositories make use of this module.+module Hackage.Security.Client.Repository.Cache (+    Cache(..)+  , getCached+  , getCachedRoot+  , getCachedIndex+  , clearCache+  , withIndex+  , getIndexIdx+  , cacheRemoteFile+  , lockCache+  ) where++import Control.Exception+import Control.Monad+import Codec.Archive.Tar (Entries(..))+import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset)+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Index as TarIndex+import qualified Codec.Compression.GZip  as GZip+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Lazy    as BS.L++import Hackage.Security.Client.Repository+import Hackage.Security.Client.Formats+import Hackage.Security.TUF+import Hackage.Security.Util.Checked+import Hackage.Security.Util.IO+import Hackage.Security.Util.Path++-- | Location and layout of the local cache+data Cache = Cache {+      cacheRoot   :: Path Absolute+    , cacheLayout :: CacheLayout+    }++-- | Cache a previously downloaded remote file+cacheRemoteFile :: forall down typ f. DownloadedFile down+                => Cache -> down typ -> Format f -> IsCached typ -> IO ()+cacheRemoteFile cache downloaded f isCached = do+    go f isCached+    case isCached of+      CacheIndex -> rebuildTarIndex cache+      _otherwise -> return ()+  where+    go :: Format f -> IsCached typ -> IO ()+    go _   DontCache      = return ()+    go FUn (CacheAs file) = copyTo (cachedFilePath cache file)+    go FGz CacheIndex     = copyTo (cachedIndexPath cache FGz) >> unzipIndex+    go _ _ = error "cacheRemoteFile: unexpected case" -- TODO: enforce in types?++    copyTo :: Path Absolute -> IO ()+    copyTo fp = do+      createDirectoryIfMissing True (takeDirectory fp)+      downloadedCopyTo downloaded fp++    -- Whether or not we downloaded the compressed index incrementally, we can+    -- always update the uncompressed index incrementally.+    -- NOTE: This assumes we already updated the compressed file.+    unzipIndex :: typ ~ Binary => IO ()+    unzipIndex = do+        createDirectoryIfMissing True (takeDirectory indexUn)+        compressed <- readLazyByteString indexGz+        let uncompressed = GZip.decompress compressed+        withFile indexUn ReadWriteMode $ \h -> do+          currentSize <- hFileSize h+          let seekTo = 0 `max` (currentSize - tarTrailer)+          hSeek h AbsoluteSeek seekTo+          BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed+      where+        indexGz = cachedIndexPath cache FGz+        indexUn = cachedIndexPath cache FUn++    tarTrailer :: Integer+    tarTrailer = 1024++-- | Rebuild the tarball index+--+-- Attempts to add to the existing index, if one exists.+--+-- TODO: Use throwChecked rather than throwUnchecked, and deal with the fallout.+-- See <https://github.com/well-typed/hackage-security/issues/84>.+rebuildTarIndex :: Cache -> IO ()+rebuildTarIndex cache = do+    (builder, offset) <- initBuilder <$> tryReadIndex (cachedIndexIdxPath cache)+    withFile (cachedIndexPath cache FUn) ReadMode $ \hTar -> do+      TarIndex.hSeekEntryOffset hTar offset+      newEntries <- Tar.read <$> BS.L.hGetContents hTar+      case addEntries builder newEntries of+        Left  ex  -> throwUnchecked ex+        Right idx -> withFile (cachedIndexIdxPath cache) WriteMode $ \hIdx -> do+                       hSetBuffering hIdx (BlockBuffering Nothing)+                       BS.hPut hIdx $ TarIndex.serialise idx+  where+    -- The initial index builder+    -- If we don't have an index (or it's broken), we start from scratch+    initBuilder :: Either e TarIndex -> (IndexBuilder, TarEntryOffset)+    initBuilder (Left  _)   = ( TarIndex.empty, 0 )+    initBuilder (Right idx) = ( TarIndex.unfinalise          idx+                              , TarIndex.indexEndEntryOffset idx+                              )++-- | Get a cached file (if available)+getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute))+getCached cache cachedFile = do+    exists <- doesFileExist localPath+    if exists then return $ Just localPath+              else return $ Nothing+  where+    localPath = cachedFilePath cache cachedFile++-- | Get the cached index (if available)+getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute))+getCachedIndex cache format = do+    exists <- doesFileExist localPath+    if exists then return $ Just localPath+              else return $ Nothing+  where+    localPath = cachedIndexPath cache format++-- | Get the cached root+--+-- Calling 'getCachedRoot' without root info available is a programmer error+-- and will result in an unchecked exception. See 'requiresBootstrap'.+getCachedRoot :: Cache -> IO (Path Absolute)+getCachedRoot cache = do+    mPath <- getCached cache CachedRoot+    case mPath of+      Just p  -> return p+      Nothing -> internalError "Client missing root info"++getIndexIdx :: Cache -> IO TarIndex+getIndexIdx cache = do+    mIndex <- tryReadIndex $ cachedIndexIdxPath cache+    case mIndex of+      Left  _   -> throwIO $ userError "Could not read index. Did you call 'checkForUpdates'?"+      Right idx -> return idx++withIndex :: Cache -> (Handle -> IO a) -> IO a+withIndex cache = withFile (cachedIndexPath cache FUn) ReadMode++-- | Delete a previously downloaded remote file+clearCache :: Cache -> IO ()+clearCache cache = void . handleDoesNotExist $ do+    removeFile $ cachedFilePath cache CachedTimestamp+    removeFile $ cachedFilePath cache CachedSnapshot++-- | Lock the cache+--+-- This avoids two concurrent processes updating the cache at the same time,+-- provided they both take the lock.+lockCache :: Cache -> IO () -> IO ()+lockCache Cache{..} = withDirLock cacheRoot++{-------------------------------------------------------------------------------+  Auxiliary: tar+-------------------------------------------------------------------------------}++-- | Variation on 'TarIndex.build' that takes in the initial 'IndexBuilder'+addEntries :: IndexBuilder -> Entries e -> Either e TarIndex+addEntries = go+  where+    go !builder (Next e es) = go (TarIndex.addNextEntry e builder) es+    go !builder  Done       = Right $! TarIndex.finalise builder+    go !_       (Fail err)  = Left err++-- TODO: How come 'deserialise' uses _strict_ ByteStrings?+tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex)+tryReadIndex fp =+    aux <$> try (TarIndex.deserialise <$> readStrictByteString fp)+  where+    aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a+    aux (Left e)              = Left (Just e)+    aux (Right Nothing)       = Left Nothing+    aux (Right (Just (a, _))) = Right a++{-------------------------------------------------------------------------------+  Auxiliary: paths+-------------------------------------------------------------------------------}++cachedFilePath :: Cache -> CachedFile -> Path Absolute+cachedFilePath Cache{cacheLayout=CacheLayout{..}, ..} file =+    anchorCachePath cacheRoot $ go file+  where+    go :: CachedFile -> CachePath+    go CachedRoot      = cacheLayoutRoot+    go CachedTimestamp = cacheLayoutTimestamp+    go CachedSnapshot  = cacheLayoutSnapshot+    go CachedMirrors   = cacheLayoutMirrors++cachedIndexPath :: Cache -> Format f -> Path Absolute+cachedIndexPath Cache{..} format =+    anchorCachePath cacheRoot $ go format+  where+    go :: Format f -> CachePath+    go FUn = cacheLayoutIndexTar   cacheLayout+    go FGz = cacheLayoutIndexTarGz cacheLayout++cachedIndexIdxPath :: Cache -> Path Absolute+cachedIndexIdxPath Cache{..} =+    anchorCachePath cacheRoot $ cacheLayoutIndexIdx cacheLayout
+ hackage-security/hackage-security/src/Hackage/Security/Client/Repository/HttpLib.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+-- | Abstracting over HTTP libraries+module Hackage.Security.Client.Repository.HttpLib (+    HttpLib(..)+  , HttpRequestHeader(..)+  , HttpResponseHeader(..)+  , HttpStatus(..)+  , ProxyConfig(..)+    -- ** Body reader+  , BodyReader+  , bodyReaderFromBS+  ) where++import Data.IORef+import Network.URI hiding (uriPath, path)+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BS.L++import Hackage.Security.Util.Checked+import Hackage.Security.Client.Repository (SomeRemoteError)++{-------------------------------------------------------------------------------+  Abstraction over HTTP clients (such as HTTP, http-conduit, etc.)+-------------------------------------------------------------------------------}++-- | Abstraction over HTTP clients+--+-- This avoids insisting on a particular implementation (such as the HTTP+-- package) and allows for other implementations (such as a conduit based one).+--+-- NOTE: Library-specific exceptions MUST be wrapped in 'SomeRemoteError'.+data HttpLib = HttpLib {+    -- | Download a file+    httpGet :: forall a. Throws SomeRemoteError+            => [HttpRequestHeader]+            -> URI+            -> ([HttpResponseHeader] -> BodyReader -> IO a)+            -> IO a++    -- | Download a byte range+    --+    -- Range is starting and (exclusive) end offset in bytes.+    --+    -- HTTP servers are normally expected to respond to a range request with+    -- a "206 Partial Content" response. However, servers can respond with a+    -- "200 OK" response, sending the entire file instead (for instance, this+    -- may happen for servers that don't actually support range rqeuests, but+    -- for which we optimistically assumed they did). Implementations of+    -- 'HttpLib' may accept such a response and inform the @hackage-security@+    -- library that the whole file is being returned; the security library can+    -- then decide to execute the 'BodyReader' anyway (downloading the entire+    -- file) or abort the request and try something else. For this reason+    -- the security library must be informed whether the server returned the+    -- full file or the requested range.+  , httpGetRange :: forall a. Throws SomeRemoteError+                 => [HttpRequestHeader]+                 -> URI+                 -> (Int, Int)+                 -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+                 -> IO a+  }++-- | Additional request headers+--+-- Since different libraries represent headers differently, here we just+-- abstract over the few request headers that we might want to set+data HttpRequestHeader =+    -- | Set @Cache-Control: max-age=0@+    HttpRequestMaxAge0++    -- | Set @Cache-Control: no-transform@+  | HttpRequestNoTransform+  deriving (Eq, Ord, Show)++-- | HTTP status code+data HttpStatus =+     -- | 200 OK+     HttpStatus200OK++     -- | 206 Partial Content+   | HttpStatus206PartialContent++-- | Response headers+--+-- Since different libraries represent headers differently, here we just+-- abstract over the few response headers that we might want to know about.+data HttpResponseHeader =+    -- | Server accepts byte-range requests (@Accept-Ranges: bytes@)+    HttpResponseAcceptRangesBytes+  deriving (Eq, Ord, Show)++-- | Proxy configuration+--+-- Although actually setting the proxy is the purview of the initialization+-- function for individual 'HttpLib' implementations and therefore outside+-- the scope of this module, we offer this 'ProxyConfiguration' type here as a+-- way to uniformly configure proxies across all 'HttpLib's.+data ProxyConfig a =+    -- | Don't use a proxy+    ProxyConfigNone++    -- | Use this specific proxy+    --+    -- Individual HTTP backends use their own types for specifying proxies.+  | ProxyConfigUse a++    -- | Use automatic proxy settings+    --+    -- What precisely automatic means is 'HttpLib' specific, though+    -- typically it will involve looking at the @HTTP_PROXY@ environment+    -- variable or the (Windows) registry.+  | ProxyConfigAuto++{-------------------------------------------------------------------------------+  Body readers+-------------------------------------------------------------------------------}++-- | An @IO@ action that represents an incoming response body coming from the+-- server.+--+-- The action gets a single chunk of data from the response body, or an empty+-- bytestring if no more data is available.+--+-- This definition is copied from the @http-client@ package.+type BodyReader = IO BS.ByteString++-- | Construct a 'Body' reader from a lazy bytestring+--+-- This is appropriate if the lazy bytestring is constructed, say, by calling+-- 'hGetContents' on a network socket, and the chunks of the bytestring+-- correspond to the chunks as they are returned from the OS network layer.+--+-- If the lazy bytestring needs to be re-chunked this function is NOT suitable.+bodyReaderFromBS :: BS.L.ByteString -> IO BodyReader+bodyReaderFromBS lazyBS = do+    chunks <- newIORef $ BS.L.toChunks lazyBS+    -- NOTE: Lazy bytestrings invariant: no empty chunks+    let br = do bss <- readIORef chunks+                case bss of+                  []        -> return BS.empty+                  (bs:bss') -> writeIORef chunks bss' >> return bs+    return br
+ hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs view
@@ -0,0 +1,99 @@+-- | Local repository+module Hackage.Security.Client.Repository.Local (+    LocalRepo+  , LocalFile -- opaque+  , withRepository+  ) where++import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.Client.Repository.Cache+import Hackage.Security.Client.Verify+import Hackage.Security.TUF+import Hackage.Security.Trusted+import Hackage.Security.Util.IO+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some++-- | Location of the repository+--+-- Note that we regard the local repository as immutable; we cache files just+-- like we do for remote repositories.+type LocalRepo = Path Absolute++-- | Initialize the repository (and cleanup resources afterwards)+--+-- Like a remote repository, a local repository takes a RepoLayout as argument;+-- but where the remote repository interprets this RepoLayout relative to a URL,+-- the local repository interprets it relative to a local directory.+--+-- It uses the same cache as the remote repository.+withRepository+  :: LocalRepo                       -- ^ Location of local repository+  -> Cache                           -- ^ Location of local cache+  -> RepoLayout                      -- ^ Repository layout+  -> IndexLayout                     -- ^ Index layout+  -> (LogMessage -> IO ())           -- ^ Logger+  -> (Repository LocalFile -> IO a)  -- ^ Callback+  -> IO a+withRepository repo+               cache+               repLayout+               repIndexLayout+               logger+               callback+               =+  callback Repository {+      repGetRemote     = getRemote repLayout repo cache+    , repGetCached     = getCached     cache+    , repGetCachedRoot = getCachedRoot cache+    , repClearCache    = clearCache    cache+    , repWithIndex     = withIndex     cache+    , repGetIndexIdx   = getIndexIdx   cache+    , repLockCache     = lockCache     cache+    , repWithMirror    = mirrorsUnsupported+    , repLog           = logger+    , repLayout        = repLayout+    , repIndexLayout   = repIndexLayout+    , repDescription   = "Local repository at " ++ pretty repo+    }++-- | Get a file from the server+getRemote :: RepoLayout -> LocalRepo -> Cache+          -> AttemptNr+          -> RemoteFile fs typ+          -> Verify (Some (HasFormat fs), LocalFile typ)+getRemote repoLayout repo cache _attemptNr remoteFile = do+    case remoteFileDefaultFormat remoteFile of+      Some format -> do+        let remotePath' = remoteRepoPath' repoLayout remoteFile format+            remotePath  = anchorRepoPathLocally repo remotePath'+            localFile   = LocalFile remotePath+        ifVerified $+          cacheRemoteFile cache+                          localFile+                          (hasFormatGet format)+                          (mustCache remoteFile)+        return (Some format, localFile)++{-------------------------------------------------------------------------------+  Files in the local repository+-------------------------------------------------------------------------------}++newtype LocalFile a = LocalFile (Path Absolute)++instance DownloadedFile LocalFile where+  downloadedVerify = verifyLocalFile+  downloadedRead   = \(LocalFile local) -> readLazyByteString local+  downloadedCopyTo = \(LocalFile local) -> copyFile local++verifyLocalFile :: LocalFile typ -> Trusted FileInfo -> IO Bool+verifyLocalFile (LocalFile fp) trustedInfo = do+    -- Verify the file size before comparing the entire file info+    sz <- FileLength <$> getFileSize fp+    if sz /= fileInfoLength+      then return False+      else knownFileInfoEqual info <$> computeFileInfo fp+  where+    info@FileInfo{..} = trusted trustedInfo
+ hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs view
@@ -0,0 +1,717 @@+{-# LANGUAGE CPP #-}+-- | An implementation of Repository that talks to repositories over HTTP.+--+-- This implementation is itself parameterized over a 'HttpClient', so that it+-- it not tied to a specific library; for instance, 'HttpClient' can be+-- implemented with the @HTTP@ library, the @http-client@ libary, or others.+--+-- It would also be possible to give _other_ Repository implementations that+-- talk to repositories over HTTP, if you want to make other design decisions+-- than we did here, in particular:+--+-- * We attempt to do incremental downloads of the index when possible.+-- * We reuse the "Repository.Local"  to deal with the local cache.+-- * We download @timestamp.json@ and @snapshot.json@ together. This is+--   implemented here because:+--   - One level down (HttpClient) we have no access to the local cache+--   - One level up (Repository API) would require _all_ Repositories to+--     implement this optimization.+module Hackage.Security.Client.Repository.Remote (+    -- * Top-level API+    withRepository+  , RepoOpts(..)+  , defaultRepoOpts+  , RemoteTemp+     -- * File sizes+  , FileSize(..)+  , fileSizeWithinBounds+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad.Cont+import Control.Monad.Except+import Data.List (nub, intercalate)+import Data.Typeable+import Network.URI hiding (uriPath, path)+import System.IO ()+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BS.L++import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.Client.Repository.Cache (Cache)+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Client.Verify+import Hackage.Security.Trusted+import Hackage.Security.TUF+import Hackage.Security.Util.Checked+import Hackage.Security.Util.IO+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some+import qualified Hackage.Security.Client.Repository.Cache as Cache++{-------------------------------------------------------------------------------+  Server capabilities+-------------------------------------------------------------------------------}++-- | Server capabilities+--+-- As the library interacts with the server and receives replies, we may+-- discover more information about the server's capabilities; for instance,+-- we may discover that it supports incremental downloads.+newtype ServerCapabilities = SC (MVar ServerCapabilities_)++-- | Internal type recording the various server capabilities we support+data ServerCapabilities_ = ServerCapabilities {+      -- | Does the server support range requests?+      serverAcceptRangesBytes :: Bool+    }++newServerCapabilities :: IO ServerCapabilities+newServerCapabilities = SC <$> newMVar ServerCapabilities {+      serverAcceptRangesBytes      = False+    }++updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()+updateServerCapabilities (SC mv) responseHeaders = modifyMVar_ mv $ \caps ->+    return $ caps {+        serverAcceptRangesBytes = serverAcceptRangesBytes caps+          || HttpResponseAcceptRangesBytes `elem` responseHeaders+      }++checkServerCapability :: MonadIO m+                      => ServerCapabilities -> (ServerCapabilities_ -> a) -> m a+checkServerCapability (SC mv) f = liftIO $ withMVar mv $ return . f++{-------------------------------------------------------------------------------+  File size+-------------------------------------------------------------------------------}++data FileSize =+    -- | For most files we download we know the exact size beforehand+    -- (because this information comes from the snapshot or delegated info)+    FileSizeExact Int54++    -- | For some files we might not know the size beforehand, but we might+    -- be able to provide an upper bound (timestamp, root info)+  | FileSizeBound Int54+  deriving Show++fileSizeWithinBounds :: Int54 -> FileSize -> Bool+fileSizeWithinBounds sz (FileSizeExact sz') = sz <= sz'+fileSizeWithinBounds sz (FileSizeBound sz') = sz <= sz'++{-------------------------------------------------------------------------------+  Top-level API+-------------------------------------------------------------------------------}++-- | Repository options with a reasonable default+--+-- Clients should use 'defaultRepositoryOpts' and override required settings.+data RepoOpts = RepoOpts {+      -- | Allow additional mirrors?+      --+      -- If this is set to True (default), in addition to the (out-of-band)+      -- specified mirrors we will also use mirrors reported by those+      -- out-of-band mirrors (that is, @mirrors.json@).+      repoAllowAdditionalMirrors :: Bool+    }++-- | Default repository options+defaultRepoOpts :: RepoOpts+defaultRepoOpts = RepoOpts {+      repoAllowAdditionalMirrors = True+    }++-- | Initialize the repository (and cleanup resources afterwards)+--+-- We allow to specify multiple mirrors to initialize the repository. These+-- are mirrors that can be found "out of band" (out of the scope of the TUF+-- protocol), for example in a @cabal.config@ file. The TUF protocol itself+-- will specify that any of these mirrors can serve a @mirrors.json@ file+-- that itself contains mirrors; we consider these as _additional_ mirrors+-- to the ones that are passed here.+--+-- NOTE: The list of mirrors should be non-empty (and should typically include+-- the primary server).+--+-- TODO: In the future we could allow finer control over precisely which+-- mirrors we use (which combination of the mirrors that are passed as arguments+-- here and the mirrors that we get from @mirrors.json@) as well as indicating+-- mirror preferences.+withRepository+  :: HttpLib                          -- ^ Implementation of the HTTP protocol+  -> [URI]                            -- ^ "Out of band" list of mirrors+  -> RepoOpts                         -- ^ Repository options+  -> Cache                            -- ^ Location of local cache+  -> RepoLayout                       -- ^ Repository layout+  -> IndexLayout                      -- ^ Index layout+  -> (LogMessage -> IO ())            -- ^ Logger+  -> (Repository RemoteTemp -> IO a)  -- ^ Callback+  -> IO a+withRepository httpLib+               outOfBandMirrors+               repoOpts+               cache+               repLayout+               repIndexLayout+               logger+               callback+               = do+    selectedMirror <- newMVar Nothing+    caps <- newServerCapabilities+    let remoteConfig mirror = RemoteConfig {+                                  cfgLayout   = repLayout+                                , cfgHttpLib  = httpLib+                                , cfgBase     = mirror+                                , cfgCache    = cache+                                , cfgCaps     = caps+                                , cfgLogger   = liftIO . logger+                                , cfgOpts     = repoOpts+                                }+    callback Repository {+        repGetRemote     = getRemote remoteConfig selectedMirror+      , repGetCached     = Cache.getCached     cache+      , repGetCachedRoot = Cache.getCachedRoot cache+      , repClearCache    = Cache.clearCache    cache+      , repWithIndex     = Cache.withIndex     cache+      , repGetIndexIdx   = Cache.getIndexIdx   cache+      , repLockCache     = Cache.lockCache     cache+      , repWithMirror    = withMirror httpLib+                                      selectedMirror+                                      logger+                                      outOfBandMirrors+                                      repoOpts+      , repLog           = logger+      , repLayout        = repLayout+      , repIndexLayout   = repIndexLayout+      , repDescription   = "Remote repository at " ++ show outOfBandMirrors+      }++{-------------------------------------------------------------------------------+  Implementations of the various methods of Repository+-------------------------------------------------------------------------------}++-- | We select a mirror in 'withMirror' (the implementation of 'repWithMirror').+-- Outside the scope of 'withMirror' no mirror is selected, and a call to+-- 'getRemote' will throw an exception. If this exception is ever thrown its+-- a bug: calls to 'getRemote' ('repGetRemote') should _always_ be in the+-- scope of 'repWithMirror'.+type SelectedMirror = MVar (Maybe URI)++-- | Get the selected mirror+--+-- Throws an exception if no mirror was selected (this would be a bug in the+-- client code).+--+-- NOTE: Cannot use 'withMVar' here, because the callback would be inside the+-- scope of the withMVar, and there might be further calls to 'withRemote' made+-- by the callback argument to 'withRemote', leading to deadlock.+getSelectedMirror :: SelectedMirror -> IO URI+getSelectedMirror selectedMirror = do+     mBaseURI <- readMVar selectedMirror+     case mBaseURI of+       Nothing      -> internalError "Internal error: no mirror selected"+       Just baseURI -> return baseURI++-- | Get a file from the server+getRemote :: Throws SomeRemoteError+          => (URI -> RemoteConfig)+          -> SelectedMirror+          -> AttemptNr+          -> RemoteFile fs typ+          -> Verify (Some (HasFormat fs), RemoteTemp typ)+getRemote remoteConfig selectedMirror attemptNr remoteFile = do+    baseURI <- liftIO $ getSelectedMirror selectedMirror+    let cfg = remoteConfig baseURI+    downloadMethod <- liftIO $ pickDownloadMethod cfg attemptNr remoteFile+    getFile cfg attemptNr remoteFile downloadMethod++-- | HTTP options+--+-- We want to make sure caches don't transform files in any way (as this will+-- mess things up with respect to hashes etc). Additionally, after a validation+-- error we want to make sure caches get files upstream in case the validation+-- error was because the cache updated files out of order.+httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader]+httpRequestHeaders RemoteConfig{..} attemptNr =+    if attemptNr == 0 then defaultHeaders+                      else HttpRequestMaxAge0 : defaultHeaders+  where+    -- Headers we provide for _every_ attempt, first or not+    defaultHeaders :: [HttpRequestHeader]+    defaultHeaders = [HttpRequestNoTransform]++-- | Mirror selection+withMirror :: forall a.+              HttpLib                -- ^ HTTP client+           -> SelectedMirror         -- ^ MVar indicating currently mirror+           -> (LogMessage -> IO ())  -- ^ Logger+           -> [URI]                  -- ^ Out-of-band mirrors+           -> RepoOpts               -- ^ Repository options+           -> Maybe [Mirror]         -- ^ TUF mirrors+           -> IO a                   -- ^ Callback+           -> IO a+withMirror HttpLib{..}+           selectedMirror+           logger+           oobMirrors+           repoOpts+           tufMirrors+           callback+           =+    go orderedMirrors+  where+    go :: [URI] -> IO a+    -- Empty list of mirrors is a bug+    go [] = internalError "No mirrors configured"+    -- If we only have a single mirror left, let exceptions be thrown up+    go [m] = do+      logger $ LogSelectedMirror (show m)+      select m $ callback+    -- Otherwise, catch exceptions and if any were thrown, try with different+    -- mirror+    go (m:ms) = do+      logger $ LogSelectedMirror (show m)+      catchChecked (select m callback) $ \ex -> do+        logger $ LogMirrorFailed (show m) ex+        go ms++    -- TODO: We will want to make the construction of this list configurable.+    orderedMirrors :: [URI]+    orderedMirrors = nub $ concat [+        oobMirrors+      , if repoAllowAdditionalMirrors repoOpts+          then maybe [] (map mirrorUrlBase) tufMirrors+          else []+      ]++    select :: URI -> IO a -> IO a+    select uri =+      bracket_ (modifyMVar_ selectedMirror $ \_ -> return $ Just uri)+               (modifyMVar_ selectedMirror $ \_ -> return Nothing)++{-------------------------------------------------------------------------------+  Download methods+-------------------------------------------------------------------------------}++-- | Download method (downloading or updating)+data DownloadMethod :: * -> * -> * where+    -- | Download this file (we never attempt to update this type of file)+    NeverUpdated :: {+        neverUpdatedFormat :: HasFormat fs f+      } -> DownloadMethod fs typ++    -- | Download this file (we cannot update this file right now)+    CannotUpdate :: {+        cannotUpdateFormat :: HasFormat fs f+      , cannotUpdateReason :: UpdateFailure+      } -> DownloadMethod fs Binary++    -- | Attempt an (incremental) update of this file+    Update :: {+        updateFormat :: HasFormat fs f+      , updateInfo   :: Trusted FileInfo+      , updateLocal  :: Path Absolute+      , updateTail   :: Int54+      } -> DownloadMethod fs Binary++pickDownloadMethod :: forall fs typ. RemoteConfig+                   -> AttemptNr+                   -> RemoteFile fs typ+                   -> IO (DownloadMethod fs typ)+pickDownloadMethod RemoteConfig{..} attemptNr remoteFile =+    case remoteFile of+      RemoteTimestamp        -> return $ NeverUpdated (HFZ FUn)+      (RemoteRoot _)         -> return $ NeverUpdated (HFZ FUn)+      (RemoteSnapshot _)     -> return $ NeverUpdated (HFZ FUn)+      (RemoteMirrors _)      -> return $ NeverUpdated (HFZ FUn)+      (RemotePkgTarGz _ _)   -> return $ NeverUpdated (HFZ FGz)+      (RemoteIndex hasGz formats) -> multipleExitPoints $ do+        -- Server must support @Range@ with a byte-range+        rangeSupport <- checkServerCapability cfgCaps serverAcceptRangesBytes+        unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported++        -- We must already have a local file to be updated+        mCachedIndex <- lift $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz)+        cachedIndex  <- case mCachedIndex of+          Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy+          Just fp -> return fp++        -- We attempt an incremental update a maximum of 2 times+        -- See 'UpdateFailedTwice' for details.+        when (attemptNr >= 2) $ exit $ CannotUpdate hasGz UpdateFailedTwice++        -- If all these checks pass try to do an incremental update.+        return Update {+             updateFormat = hasGz+           , updateInfo   = formatsLookup hasGz formats+           , updateLocal  = cachedIndex+           , updateTail   = 65536 -- max gzip block size+           }++-- | Download the specified file using the given download method+getFile :: forall fs typ. Throws SomeRemoteError+        => RemoteConfig          -- ^ Internal configuration+        -> AttemptNr             -- ^ Did a security check previously fail?+        -> RemoteFile fs typ     -- ^ File to get+        -> DownloadMethod fs typ -- ^ Selected format+        -> Verify (Some (HasFormat fs), RemoteTemp typ)+getFile cfg@RemoteConfig{..} attemptNr remoteFile method =+    go method+  where+    go :: Throws SomeRemoteError+       => DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)+    go NeverUpdated{..} = do+        cfgLogger $ LogDownloading remoteFile+        download neverUpdatedFormat+    go CannotUpdate{..} = do+        cfgLogger $ LogCannotUpdate remoteFile cannotUpdateReason+        cfgLogger $ LogDownloading remoteFile+        download cannotUpdateFormat+    go Update{..} = do+        cfgLogger $ LogUpdating remoteFile+        update updateFormat updateInfo updateLocal updateTail++    headers :: [HttpRequestHeader]+    headers = httpRequestHeaders cfg attemptNr++    -- Get any file from the server, without using incremental updates+    download :: Throws SomeRemoteError => HasFormat fs f+             -> Verify (Some (HasFormat fs), RemoteTemp typ)+    download format = do+        (tempPath, h) <- openTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri)+        liftIO $ do+          httpGet headers uri $ \responseHeaders bodyReader -> do+            updateServerCapabilities cfgCaps responseHeaders+            execBodyReader targetPath sz h bodyReader+          hClose h+        cacheIfVerified format $ DownloadedWhole tempPath+      where+        targetPath = TargetPathRepo $ remoteRepoPath' cfgLayout remoteFile format+        uri = formatsLookup format $ remoteFileURI cfgLayout cfgBase remoteFile+        sz  = formatsLookup format $ remoteFileSize remoteFile++    -- Get a file incrementally+    update :: (typ ~ Binary)+           => HasFormat fs f    -- ^ Selected format+           -> Trusted FileInfo  -- ^ Expected info+           -> Path Absolute     -- ^ Location of cached file (after callback)+           -> Int54             -- ^ How much of the tail to overwrite+           -> Verify (Some (HasFormat fs), RemoteTemp typ)+    update format info cachedFile fileTail = do+        currentSz <- liftIO $ getFileSize cachedFile+        let fileSz    = fileLength' info+            range     = (0 `max` (currentSz - fileTail), fileSz)+            range'    = (fromIntegral (fst range), fromIntegral (snd range))+            cacheRoot = Cache.cacheRoot cfgCache+        (tempPath, h) <- openTempFile cacheRoot (uriTemplate uri)+        statusCode <- liftIO $+          httpGetRange headers uri range' $ \statusCode responseHeaders bodyReader -> do+            updateServerCapabilities cfgCaps responseHeaders+            let expectedSize =+                  case statusCode of+                    HttpStatus206PartialContent ->+                      FileSizeExact (snd range - fst range)+                    HttpStatus200OK ->+                      FileSizeExact fileSz+            execBodyReader targetPath expectedSize h bodyReader+            hClose h+            return statusCode+        let downloaded =+              case statusCode of+                HttpStatus206PartialContent ->+                  DownloadedDelta {+                      deltaTemp     = tempPath+                    , deltaExisting = cachedFile+                    , deltaSeek     = fst range+                    }+                HttpStatus200OK ->+                  DownloadedWhole tempPath+        cacheIfVerified format downloaded+      where+        targetPath = TargetPathRepo repoPath+        uri        = modifyUriPath cfgBase (`anchorRepoPathRemotely` repoPath)+        repoPath   = remoteRepoPath' cfgLayout remoteFile format++    cacheIfVerified :: HasFormat fs f -> RemoteTemp typ+                    -> Verify (Some (HasFormat fs), RemoteTemp typ)+    cacheIfVerified format remoteTemp = do+        ifVerified $+          Cache.cacheRemoteFile cfgCache+                                remoteTemp+                                (hasFormatGet format)+                                (mustCache remoteFile)+        return (Some format, remoteTemp)++    HttpLib{..} = cfgHttpLib++{-------------------------------------------------------------------------------+  Execute body reader+-------------------------------------------------------------------------------}++-- | Execute a body reader+--+-- TODO: Deal with minimum download rate.+execBodyReader :: Throws SomeRemoteError+               => TargetPath  -- ^ File source (for error msgs only)+               -> FileSize    -- ^ Maximum file size+               -> Handle      -- ^ Handle to write data too+               -> BodyReader  -- ^ The action to give us blocks from the file+               -> IO ()+execBodyReader file mlen h br = go 0+  where+    go :: Int54 -> IO ()+    go sz = do+      unless (sz `fileSizeWithinBounds` mlen) $+        throwChecked $ SomeRemoteError $ FileTooLarge file mlen+      bs <- br+      if BS.null bs+        then return ()+        else BS.hPut h bs >> go (sz + fromIntegral (BS.length bs))++-- | The file we requested from the server was larger than expected+-- (potential endless data attack)+data FileTooLarge = FileTooLarge {+    fileTooLargePath     :: TargetPath+  , fileTooLargeExpected :: FileSize+  }+  deriving (Typeable)++instance Pretty FileTooLarge where+  pretty FileTooLarge{..} = concat [+      "file returned by server too large: "+    , pretty fileTooLargePath+    , " (expected " ++ expected fileTooLargeExpected ++ " bytes)"+    ]+    where+      expected :: FileSize -> String+      expected (FileSizeExact n) = "exactly " ++ show n+      expected (FileSizeBound n) = "at most " ++ show n++#if MIN_VERSION_base(4,8,0)+deriving instance Show FileTooLarge+instance Exception FileTooLarge where displayException = pretty+#else+instance Exception FileTooLarge+instance Show FileTooLarge where show = pretty+#endif++{-------------------------------------------------------------------------------+  Information about remote files+-------------------------------------------------------------------------------}++remoteFileURI :: RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI+remoteFileURI repoLayout baseURI = fmap aux . remoteRepoPath repoLayout+  where+    aux :: RepoPath -> URI+    aux repoPath = modifyUriPath baseURI (`anchorRepoPathRemotely` repoPath)++-- | Extracting or estimating file sizes+remoteFileSize :: RemoteFile fs typ -> Formats fs FileSize+remoteFileSize (RemoteTimestamp) =+    FsUn $ FileSizeBound fileSizeBoundTimestamp+remoteFileSize (RemoteRoot mLen) =+    FsUn $ maybe (FileSizeBound fileSizeBoundRoot)+                 (FileSizeExact . fileLength')+                 mLen+remoteFileSize (RemoteSnapshot len) =+    FsUn $ FileSizeExact (fileLength' len)+remoteFileSize (RemoteMirrors len) =+    FsUn $ FileSizeExact (fileLength' len)+remoteFileSize (RemoteIndex _ lens) =+    fmap (FileSizeExact . fileLength') lens+remoteFileSize (RemotePkgTarGz _pkgId len) =+    FsGz $ FileSizeExact (fileLength' len)++-- | Bound on the size of the timestamp+--+-- This is intended as a permissive rather than tight bound.+--+-- The timestamp signed with a single key is 420 bytes; the signature makes up+-- just under 200 bytes of that. So even if the timestamp is signed with 10+-- keys it would still only be 2420 bytes. Doubling this amount, an upper bound+-- of 4kB should definitely be sufficient.+fileSizeBoundTimestamp :: Int54+fileSizeBoundTimestamp = 4096++-- | Bound on the size of the root+--+-- This is intended as a permissive rather than tight bound.+--+-- The variable parts of the root metadata are+--+-- * Signatures, each of which are about 200 bytes+-- * A key environment (mapping from key IDs to public keys), each is of+--   which is also about 200 bytes+-- * Mirrors, root, snapshot, targets, and timestamp role specifications.+--   These contains key IDs, each of which is about 80 bytes.+--+-- A skeleton root metadata is about 580 bytes. Allowing for+--+-- * 100 signatures+-- * 100 mirror keys, 1000 root keys, 100 snapshot keys, 1000 target keys,+--   100 timestamp keys+-- * the corresponding 2300 entries in the key environment+--+-- We end up with a bound of about 665,000 bytes. Doubling this amount, an+-- upper bound of 2MB should definitely be sufficient.+fileSizeBoundRoot :: Int54+fileSizeBoundRoot = 2 * 1024 * 2014++{-------------------------------------------------------------------------------+  Configuration+-------------------------------------------------------------------------------}++-- | Remote repository configuration+--+-- This is purely for internal convenience.+data RemoteConfig = RemoteConfig {+      cfgLayout   :: RepoLayout+    , cfgHttpLib  :: HttpLib+    , cfgBase     :: URI+    , cfgCache    :: Cache+    , cfgCaps     :: ServerCapabilities+    , cfgLogger   :: forall m. MonadIO m => LogMessage -> m ()+    , cfgOpts     :: RepoOpts+    }++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Template for the local file we use to download a URI to+uriTemplate :: URI -> String+uriTemplate = takeFileName . uriPath++fileLength' :: Trusted FileInfo -> Int54+fileLength' = fileLength . fileInfoLength . trusted++{-------------------------------------------------------------------------------+  Files downloaded from the remote repository+-------------------------------------------------------------------------------}++data RemoteTemp :: * -> * where+    DownloadedWhole :: {+        wholeTemp :: Path Absolute+      } -> RemoteTemp a++    -- | If we download only the delta, we record both the path to where the+    -- "old" file is stored and the path to the temp file containing the delta.+    -- Then:+    --+    -- * When we verify the file, we need both of these paths if we compute+    --   the hash from scratch, or only the path to the delta if we attempt+    --   to compute the hash incrementally (TODO: incremental verification+    --   not currently implemented).+    -- * When we copy a file over, we are additionally given a destination+    --   path. In this case, we expect that destination path to be equal to+    --   the path to the old file (and assert this to be the case).+    DownloadedDelta :: {+        deltaTemp     :: Path Absolute+      , deltaExisting :: Path Absolute+      , deltaSeek     :: Int54       -- ^ How much of the existing file to keep+      } -> RemoteTemp Binary++instance Pretty (RemoteTemp typ) where+    pretty DownloadedWhole{..} = intercalate " " $ [+        "DownloadedWhole"+      , pretty wholeTemp+      ]+    pretty DownloadedDelta{..} = intercalate " " $ [+        "DownloadedDelta"+      , pretty deltaTemp+      , pretty deltaExisting+      , show deltaSeek+      ]++instance DownloadedFile RemoteTemp where+  downloadedVerify = verifyRemoteFile+  downloadedRead   = readLazyByteString . wholeTemp+  downloadedCopyTo = \f dest ->+    case f of+      DownloadedWhole{..} ->+        renameFile wholeTemp dest+      DownloadedDelta{..} -> do+        unless (deltaExisting == dest) $+          throwIO $ userError "Assertion failure: deltaExisting /= dest"+        -- We need ReadWriteMode in order to be able to seek+        withFile deltaExisting ReadWriteMode $ \h -> do+          hSeek h AbsoluteSeek (fromIntegral deltaSeek)+          BS.L.hPut h =<< readLazyByteString deltaTemp++-- | Verify a file downloaded from the remote repository+--+-- TODO: This currently still computes the hash for the whole file. If we cached+-- the state of the hash generator we could compute the hash incrementally.+-- However, profiling suggests that this would only be a minor improvement.+verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool+verifyRemoteFile remoteTemp trustedInfo = do+    sz <- FileLength <$> remoteSize remoteTemp+    if sz /= fileInfoLength+      then return False+      else withRemoteBS remoteTemp $ knownFileInfoEqual info . fileInfo+  where+    remoteSize :: RemoteTemp typ -> IO Int54+    remoteSize DownloadedWhole{..} = getFileSize wholeTemp+    remoteSize DownloadedDelta{..} = do+        deltaSize <- getFileSize deltaTemp+        return $ deltaSeek + deltaSize++    -- It is important that we close the file handles when we're done+    -- (esp. since we may not read the whole file)+    withRemoteBS :: RemoteTemp typ -> (BS.L.ByteString -> Bool) -> IO Bool+    withRemoteBS DownloadedWhole{..} callback = do+        withFile wholeTemp ReadMode $ \h -> do+          bs <- BS.L.hGetContents h+          evaluate $ callback bs+    withRemoteBS DownloadedDelta{..} callback =+        withFile deltaExisting ReadMode $ \hExisting ->+          withFile deltaTemp ReadMode $ \hTemp -> do+            existing <- BS.L.hGetContents hExisting+            temp     <- BS.L.hGetContents hTemp+            evaluate $ callback $ BS.L.concat [+                BS.L.take (fromIntegral deltaSeek) existing+              , temp+              ]++    info@FileInfo{..} = trusted trustedInfo++{-------------------------------------------------------------------------------+  Auxiliary: multiple exit points+-------------------------------------------------------------------------------}++-- | Multiple exit points+--+-- We can simulate the imperative code+--+-- > if (cond1)+-- >   return exp1;+-- > if (cond2)+-- >   return exp2;+-- > if (cond3)+-- >   return exp3;+-- > return exp4;+--+-- as+--+-- > multipleExitPoints $ do+-- >   when (cond1) $+-- >     exit exp1+-- >   when (cond) $+-- >     exit exp2+-- >   when (cond)+-- >     exit exp3+-- >   return exp4+multipleExitPoints :: Monad m => ExceptT a m a -> m a+multipleExitPoints = liftM aux . runExceptT+  where+    aux :: Either a a -> a+    aux (Left  a) = a+    aux (Right a) = a++-- | Function exit point (see 'multipleExitPoints')+exit :: Monad m => e -> ExceptT e m a+exit = throwError
+ hackage-security/hackage-security/src/Hackage/Security/Client/Verify.hs view
@@ -0,0 +1,103 @@+module Hackage.Security.Client.Verify (+    -- * Verification monad+    Verify -- opaque+  , runVerify+  , acquire+  , ifVerified+    -- * Specific resources+  , openTempFile+    -- * Re-exports+  , liftIO+  ) where++import Control.Exception+import Control.Monad.Reader+import Data.IORef++import Hackage.Security.Util.IO+import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Verification monad+-------------------------------------------------------------------------------}++type Finaliser = IO ()+type Cleanup   = IO ()++-- | Verification monad+--+-- The verification monad is similar to 'ResourceT' in intent, in that we can+-- register handlers to be run to release resources. Unlike 'ResourceT',+-- however, we maintain _two_ handlers: a cleanup handler which is run  whether+-- or not verification succeeds, and a finalisation handler which is run only if+-- verification succeeds.+--+-- * Cleanup handlers are registered using 'acquire', and are guaranteed to run+--   just before the computation terminates (after the finalisation handler).+-- * The finalisation handlers are run only when verification succeeds, and can+--   be registered with 'ifVerified'. Finalisation can be used for instance to+--   update the local cache (which should only happen if verification is+--   successful).+newtype Verify a = Verify {+    unVerify :: ReaderT (IORef Cleanup, IORef Finaliser) IO a+  }+  deriving (Functor, Applicative, Monad, MonadIO)++-- | Run an action in the 'Verify' monad+runVerify :: (Finaliser -> Finaliser) -> Verify a -> IO a+runVerify modifyFinaliser v = do+    rCleanup   <- newIORef $ return ()+    rFinaliser <- newIORef $ return ()+    mask $ \restore -> do+      ma <- try $ restore $ runReaderT (unVerify v) (rCleanup, rFinaliser)+      case ma of+        Left ex -> do join $ readIORef rCleanup+                      throwIO (ex :: SomeException)+        Right a -> do modifyFinaliser $ join $ readIORef rFinaliser+                      join $ readIORef rCleanup+                      return a++-- | Acquire a resource and register the corresponding cleanup handler+--+-- NOTE: Resource acquisition happens with exceptions masked. If it is important+-- that the resource acquistion can be timed out (or receive other kinds of+-- asynchronous exceptions), you will need to use an interruptible operation.+-- See <http://www.well-typed.com/blog/2014/08/asynchronous-exceptions/> for+-- details.+acquire :: IO a -> (a -> IO ()) -> Verify a+acquire get release = Verify $ do+    (rCleanup, _rFinaliser) <- ask+    liftIO $ mask_ $ do+      a <- liftIO get+      modifyIORef rCleanup (>> release a)+      return a++-- | Register an action to be run only if verification succeeds+ifVerified :: IO () -> Verify ()+ifVerified handler = Verify $ do+    (_rCleanup, rFinaliser) <- ask+    liftIO $ modifyIORef rFinaliser (>> handler)++{-------------------------------------------------------------------------------+  Specific resources+-------------------------------------------------------------------------------}++-- | Create a short-lived temporary file+--+-- Creates the directory where the temp file should live if it does not exist.+openTempFile :: FsRoot root+             => Path root  -- ^ Temp directory+             -> String     -- ^ Template+             -> Verify (Path Absolute, Handle)+openTempFile tmpDir template =+    acquire createTempFile closeAndDelete+  where+    createTempFile :: IO (Path Absolute, Handle)+    createTempFile = do+      createDirectoryIfMissing True tmpDir+      openTempFile' tmpDir template++    closeAndDelete :: (Path Absolute, Handle) -> IO ()+    closeAndDelete (fp, h) = do+      hClose h+      void $ handleDoesNotExist $ removeFile fp
+ hackage-security/hackage-security/src/Hackage/Security/JSON.hs view
@@ -0,0 +1,323 @@+-- | Hackage-specific wrappers around the Util.JSON module+{-# LANGUAGE CPP #-}+module Hackage.Security.JSON (+    -- * Deserialization errors+    DeserializationError(..)+  , validate+  , verifyType+    -- * MonadKeys+  , MonadKeys(..)+  , addKeys+  , withKeys+  , lookupKey+  , readKeyAsId+    -- * Reader monads+  , ReadJSON_Keys_Layout+  , ReadJSON_Keys_NoLayout+  , ReadJSON_NoKeys_NoLayout+  , runReadJSON_Keys_Layout+  , runReadJSON_Keys_NoLayout+  , runReadJSON_NoKeys_NoLayout+    -- ** Utility+  , parseJSON_Keys_Layout+  , parseJSON_Keys_NoLayout+  , parseJSON_NoKeys_NoLayout+  , readJSON_Keys_Layout+  , readJSON_Keys_NoLayout+  , readJSON_NoKeys_NoLayout+    -- * Writing+  , WriteJSON+  , runWriteJSON+    -- ** Utility+  , renderJSON+  , renderJSON_NoLayout+  , writeJSON+  , writeJSON_NoLayout+  , writeKeyAsId+    -- * Re-exports+  , module Hackage.Security.Util.JSON+  ) where++import Control.Arrow (first, second)+import Control.Exception+import Control.Monad.Except+import Control.Monad.Reader+import Data.Functor.Identity+import Data.Typeable (Typeable)+import qualified Data.ByteString.Lazy as BS.L++import Hackage.Security.Key+import Hackage.Security.Key.Env (KeyEnv)+import Hackage.Security.TUF.Layout.Repo+import Hackage.Security.Util.JSON+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some+import Text.JSON.Canonical+import qualified Hackage.Security.Key.Env as KeyEnv++{-------------------------------------------------------------------------------+  Deserialization errors+-------------------------------------------------------------------------------}++data DeserializationError =+    -- | Malformed JSON has syntax errors in the JSON itself+    -- (i.e., we cannot even parse it to a JSValue)+    DeserializationErrorMalformed String++    -- | Invalid JSON has valid syntax but invalid structure+    --+    -- The string gives a hint about what we expected instead+  | DeserializationErrorSchema String++    -- | The JSON file contains a key ID of an unknown key+  | DeserializationErrorUnknownKey KeyId++    -- | Some verification step failed+  | DeserializationErrorValidation String++    -- | Wrong file type+    --+    -- Records actual and expected types.+  | DeserializationErrorFileType String String+  deriving (Typeable)++#if MIN_VERSION_base(4,8,0)+deriving instance Show DeserializationError+instance Exception DeserializationError where displayException = pretty+#else+instance Show DeserializationError where show = pretty+instance Exception DeserializationError+#endif++instance Pretty DeserializationError where+  pretty (DeserializationErrorMalformed str) =+      "Malformed: " ++ str+  pretty (DeserializationErrorSchema str) =+      "Schema error: " ++ str+  pretty (DeserializationErrorUnknownKey kId) =+      "Unknown key: " ++ keyIdString kId+  pretty (DeserializationErrorValidation str) =+      "Invalid: " ++ str+  pretty (DeserializationErrorFileType actualType expectedType) =+         "Expected file of type " ++ show expectedType+      ++ " but got file of type " ++ show actualType++validate :: MonadError DeserializationError m => String -> Bool -> m ()+validate _   True  = return ()+validate msg False = throwError $ DeserializationErrorValidation msg++verifyType :: (ReportSchemaErrors m, MonadError DeserializationError m)+           => JSValue -> String -> m ()+verifyType enc expectedType = do+    actualType <- fromJSField enc "_type"+    unless (actualType == expectedType) $+      throwError $ DeserializationErrorFileType actualType expectedType++{-------------------------------------------------------------------------------+  Access to keys+-------------------------------------------------------------------------------}++-- | MonadReader-like monad, specialized to key environments+class (ReportSchemaErrors m, MonadError DeserializationError m) => MonadKeys m where+  localKeys :: (KeyEnv -> KeyEnv) -> m a -> m a+  askKeys   :: m KeyEnv++readKeyAsId :: MonadKeys m => JSValue -> m (Some PublicKey)+readKeyAsId (JSString kId) = lookupKey (KeyId kId)+readKeyAsId val            = expected' "key ID" val++addKeys :: MonadKeys m => KeyEnv -> m a -> m a+addKeys keys = localKeys (KeyEnv.union keys)++withKeys :: MonadKeys m => KeyEnv -> m a -> m a+withKeys keys = localKeys (const keys)++lookupKey :: MonadKeys m => KeyId -> m (Some PublicKey)+lookupKey kId = do+    keyEnv <- askKeys+    case KeyEnv.lookup kId keyEnv of+      Just key -> return key+      Nothing  -> throwError $ DeserializationErrorUnknownKey kId++{-------------------------------------------------------------------------------+  Reading+-------------------------------------------------------------------------------}++newtype ReadJSON_Keys_Layout a = ReadJSON_Keys_Layout {+    unReadJSON_Keys_Layout :: ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadError DeserializationError+           )++newtype ReadJSON_Keys_NoLayout a = ReadJSON_Keys_NoLayout {+    unReadJSON_Keys_NoLayout :: ExceptT DeserializationError (Reader KeyEnv) a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadError DeserializationError+           )++newtype ReadJSON_NoKeys_NoLayout a = ReadJSON_NoKeys_NoLayout {+    unReadJSON_NoKeys_NoLayout :: Except DeserializationError a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadError DeserializationError+           )++instance ReportSchemaErrors ReadJSON_Keys_Layout where+  expected str mgot = throwError $ expectedError str mgot+instance ReportSchemaErrors ReadJSON_Keys_NoLayout where+  expected str mgot = throwError $ expectedError str mgot+instance ReportSchemaErrors ReadJSON_NoKeys_NoLayout where+  expected str mgot = throwError $ expectedError str mgot++expectedError :: Expected -> Maybe Got -> DeserializationError+expectedError str mgot = DeserializationErrorSchema msg+  where+    msg = case mgot of+            Nothing  -> "Expected " ++ str+            Just got -> "Expected " ++ str ++ " but got " ++ got++instance MonadReader RepoLayout ReadJSON_Keys_Layout where+  ask         = ReadJSON_Keys_Layout $ fst `liftM` ask+  local f act = ReadJSON_Keys_Layout $ local (first f) act'+    where+      act' = unReadJSON_Keys_Layout act++instance MonadKeys ReadJSON_Keys_Layout where+  askKeys         = ReadJSON_Keys_Layout $ snd `liftM` ask+  localKeys f act = ReadJSON_Keys_Layout $ local (second f) act'+    where+      act' = unReadJSON_Keys_Layout act++instance MonadKeys ReadJSON_Keys_NoLayout where+  askKeys         = ReadJSON_Keys_NoLayout $ ask+  localKeys f act = ReadJSON_Keys_NoLayout $ local f act'+    where+      act' = unReadJSON_Keys_NoLayout act++runReadJSON_Keys_Layout :: KeyEnv+                        -> RepoLayout+                        -> ReadJSON_Keys_Layout a+                        -> Either DeserializationError a+runReadJSON_Keys_Layout keyEnv repoLayout act =+    runReader (runExceptT (unReadJSON_Keys_Layout act)) (repoLayout, keyEnv)++runReadJSON_Keys_NoLayout :: KeyEnv+                          -> ReadJSON_Keys_NoLayout a+                          -> Either DeserializationError a+runReadJSON_Keys_NoLayout keyEnv act =+    runReader (runExceptT (unReadJSON_Keys_NoLayout act)) keyEnv++runReadJSON_NoKeys_NoLayout :: ReadJSON_NoKeys_NoLayout a+                            -> Either DeserializationError a+runReadJSON_NoKeys_NoLayout act =+    runExcept (unReadJSON_NoKeys_NoLayout act)++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++parseJSON_Keys_Layout :: FromJSON ReadJSON_Keys_Layout a+                      => KeyEnv+                      -> RepoLayout+                      -> BS.L.ByteString+                      -> Either DeserializationError a+parseJSON_Keys_Layout keyEnv repoLayout bs =+    case parseCanonicalJSON bs of+      Left  err -> Left (DeserializationErrorMalformed err)+      Right val -> runReadJSON_Keys_Layout keyEnv repoLayout (fromJSON val)++parseJSON_Keys_NoLayout :: FromJSON ReadJSON_Keys_NoLayout a+                        => KeyEnv+                        -> BS.L.ByteString+                        -> Either DeserializationError a+parseJSON_Keys_NoLayout keyEnv bs =+    case parseCanonicalJSON bs of+      Left  err -> Left (DeserializationErrorMalformed err)+      Right val -> runReadJSON_Keys_NoLayout keyEnv (fromJSON val)++parseJSON_NoKeys_NoLayout :: FromJSON ReadJSON_NoKeys_NoLayout a+                          => BS.L.ByteString+                          -> Either DeserializationError a+parseJSON_NoKeys_NoLayout bs =+    case parseCanonicalJSON bs of+      Left  err -> Left (DeserializationErrorMalformed err)+      Right val -> runReadJSON_NoKeys_NoLayout (fromJSON val)++readJSON_Keys_Layout :: ( FsRoot root+                        , FromJSON ReadJSON_Keys_Layout a+                        )+                     => KeyEnv+                     -> RepoLayout+                     -> Path root+                     -> IO (Either DeserializationError a)+readJSON_Keys_Layout keyEnv repoLayout fp = do+    withFile fp ReadMode $ \h -> do+      bs <- BS.L.hGetContents h+      evaluate $ parseJSON_Keys_Layout keyEnv repoLayout bs++readJSON_Keys_NoLayout :: ( FsRoot root+                          , FromJSON ReadJSON_Keys_NoLayout a+                          )+                       => KeyEnv+                       -> Path root+                       -> IO (Either DeserializationError a)+readJSON_Keys_NoLayout keyEnv fp = do+    withFile fp ReadMode $ \h -> do+      bs <- BS.L.hGetContents h+      evaluate $ parseJSON_Keys_NoLayout keyEnv bs++readJSON_NoKeys_NoLayout :: ( FsRoot root+                            , FromJSON ReadJSON_NoKeys_NoLayout a+                            )+                         => Path root+                         -> IO (Either DeserializationError a)+readJSON_NoKeys_NoLayout fp = do+    withFile fp ReadMode $ \h -> do+      bs <- BS.L.hGetContents h+      evaluate $ parseJSON_NoKeys_NoLayout bs++{-------------------------------------------------------------------------------+  Writing+-------------------------------------------------------------------------------}++newtype WriteJSON a = WriteJSON {+    unWriteJSON :: Reader RepoLayout a+  }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadReader RepoLayout+           )++runWriteJSON :: RepoLayout -> WriteJSON a -> a+runWriteJSON repoLayout act = runReader (unWriteJSON act) repoLayout++{-------------------------------------------------------------------------------+  Writing: Utility+-------------------------------------------------------------------------------}++-- | Render to canonical JSON format+renderJSON :: ToJSON WriteJSON a => RepoLayout -> a -> BS.L.ByteString+renderJSON repoLayout = renderCanonicalJSON . runWriteJSON repoLayout . toJSON++-- | Variation on 'renderJSON' for files that don't require the repo layout+renderJSON_NoLayout :: ToJSON Identity a => a -> BS.L.ByteString+renderJSON_NoLayout = renderCanonicalJSON . runIdentity . toJSON++writeJSON :: ToJSON WriteJSON a => RepoLayout -> Path Absolute -> a -> IO ()+writeJSON repoLayout fp = writeLazyByteString fp . renderJSON repoLayout++writeJSON_NoLayout :: ToJSON Identity a => Path Absolute -> a -> IO ()+writeJSON_NoLayout fp = writeLazyByteString fp . renderJSON_NoLayout++writeKeyAsId :: Some PublicKey -> JSValue+writeKeyAsId = JSString . keyIdString . someKeyId
+ hackage-security/hackage-security/src/Hackage/Security/Key.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE CPP #-}+module Hackage.Security.Key (+    -- * Key types+    Ed25519+    -- * Types abstracting over key types+  , Key(..)+  , PublicKey(..)+  , PrivateKey(..)+    -- * Key types in isolation+  , KeyType(..)+    -- * Hiding key types+  , somePublicKey+  , somePublicKeyType+  , someKeyId+    -- * Operations on keys+  , publicKey+  , privateKey+  , createKey+  , createKey'+    -- * Key IDs+  , KeyId(..)+  , HasKeyId(..)+    -- * Signing+  , sign+  , verify+  ) where++import Control.Monad+import Data.Functor.Identity+import Data.Typeable (Typeable)+import Text.JSON.Canonical+import qualified Crypto.Hash          as CH+import qualified Crypto.Sign.Ed25519  as Ed25519+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BS.L++#if !MIN_VERSION_base(4,7,0)+import qualified Data.Typeable as Typeable+#endif++import Hackage.Security.Util.JSON+import Hackage.Security.Util.Some+import Hackage.Security.Util.TypedEmbedded+import qualified Hackage.Security.Util.Base64 as B64++{-------------------------------------------------------------------------------+  Generalization over key types+-------------------------------------------------------------------------------}++data Ed25519++data Key a where+    KeyEd25519 :: Ed25519.PublicKey -> Ed25519.SecretKey -> Key Ed25519+  deriving (Typeable)++data PublicKey a where+    PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519+  deriving (Typeable)++data PrivateKey a where+    PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519+  deriving (Typeable)++deriving instance Show (Key        typ)+deriving instance Show (PublicKey  typ)+deriving instance Show (PrivateKey typ)++deriving instance Eq (Key        typ)+deriving instance Eq (PublicKey  typ)+deriving instance Eq (PrivateKey typ)++instance SomeShow Key        where someShow = DictShow+instance SomeShow PublicKey  where someShow = DictShow+instance SomeShow PrivateKey where someShow = DictShow++instance SomeEq Key        where someEq = DictEq+instance SomeEq PublicKey  where someEq = DictEq+instance SomeEq PrivateKey where someEq = DictEq++publicKey :: Key a -> PublicKey a+publicKey (KeyEd25519 pub _pri) = PublicKeyEd25519 pub++privateKey :: Key a -> PrivateKey a+privateKey (KeyEd25519 _pub pri) = PrivateKeyEd25519 pri++{-------------------------------------------------------------------------------+  Sometimes it's useful to talk about the type of a key independent of the key+-------------------------------------------------------------------------------}++data KeyType typ where+  KeyTypeEd25519 :: KeyType Ed25519++deriving instance Show (KeyType typ)+deriving instance Eq   (KeyType typ)++instance SomeShow KeyType where someShow = DictShow+instance SomeEq   KeyType where someEq   = DictEq++instance Unify KeyType where+  unify KeyTypeEd25519 KeyTypeEd25519 = Just Refl++type instance TypeOf Key        = KeyType+type instance TypeOf PublicKey  = KeyType+type instance TypeOf PrivateKey = KeyType++instance Typed Key where+  typeOf (KeyEd25519 _ _) = KeyTypeEd25519++instance Typed PublicKey where+  typeOf (PublicKeyEd25519 _) = KeyTypeEd25519++instance Typed PrivateKey where+  typeOf (PrivateKeyEd25519 _) = KeyTypeEd25519++{-------------------------------------------------------------------------------+  We don't always know the key type+-------------------------------------------------------------------------------}++somePublicKey :: Some Key -> Some PublicKey+somePublicKey (Some key) = Some (publicKey key)++somePublicKeyType :: Some PublicKey -> Some KeyType+somePublicKeyType (Some pub) = Some (typeOf pub)++someKeyId :: HasKeyId key => Some key -> KeyId+someKeyId (Some a) = keyId a++{-------------------------------------------------------------------------------+  Creating keys+-------------------------------------------------------------------------------}++createKey :: KeyType key -> IO (Key key)+createKey KeyTypeEd25519 = uncurry KeyEd25519 <$> Ed25519.createKeypair++createKey' :: KeyType key -> IO (Some Key)+createKey' = liftM Some . createKey++{-------------------------------------------------------------------------------+  Key IDs+-------------------------------------------------------------------------------}++-- | The key ID of a key, by definition, is the hexdigest of the SHA-256 hash of+-- the canonical JSON form of the key where the private object key is excluded.+--+-- NOTE: The FromJSON and ToJSON instances for KeyId are ntentially omitted. Use+-- writeKeyAsId instead.+newtype KeyId = KeyId { keyIdString :: String }+  deriving (Show, Eq, Ord)++instance Monad m => ToObjectKey m KeyId where+  toObjectKey = return . keyIdString++instance Monad m => FromObjectKey m KeyId where+  fromObjectKey = return . KeyId++-- | Compute the key ID of a key+class HasKeyId key where+  keyId :: key typ -> KeyId++instance HasKeyId PublicKey where+  keyId = KeyId+        . show+        . (CH.hashlazy :: BS.L.ByteString -> CH.Digest CH.SHA256)+        . renderCanonicalJSON+        . runIdentity+        . toJSON++instance HasKeyId Key where+  keyId = keyId . publicKey++{-------------------------------------------------------------------------------+  Signing+-------------------------------------------------------------------------------}++-- | Sign a bytestring and return the signature+--+-- TODO: It is unfortunate that we have to convert to a strict bytestring for+-- ed25519+sign :: PrivateKey typ -> BS.L.ByteString -> BS.ByteString+sign (PrivateKeyEd25519 pri) =+    Ed25519.unSignature . dsign pri . BS.concat . BS.L.toChunks+  where+#if MIN_VERSION_ed25519(0,0,4)+    dsign = Ed25519.dsign+#else+    dsign = Ed25519.sign'+#endif++verify :: PublicKey typ -> BS.L.ByteString -> BS.ByteString -> Bool+verify (PublicKeyEd25519 pub) inp sig =+    dverify pub (BS.concat $ BS.L.toChunks inp) (Ed25519.Signature sig)+  where+#if MIN_VERSION_ed25519(0,0,4)+    dverify = Ed25519.dverify+#else+    dverify = Ed25519.verify'+#endif++{-------------------------------------------------------------------------------+  JSON encoding and decoding+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m (Key typ) where+  toJSON key = case key of+      KeyEd25519 pub pri ->+        enc "ed25519" (Ed25519.unPublicKey pub) (Ed25519.unSecretKey pri)+    where+      enc :: String -> BS.ByteString -> BS.ByteString -> m JSValue+      enc tag pub pri = mkObject [+            ("keytype", return $ JSString tag)+          , ("keyval", mkObject [+                ("public",  toJSON (B64.fromByteString pub))+              , ("private", toJSON (B64.fromByteString pri))+              ])+          ]++instance ReportSchemaErrors m => FromJSON m (Some Key) where+  fromJSON enc = do+      (tag, pub, pri) <- dec enc+      case tag of+        "ed25519" -> return . Some $+          KeyEd25519 (Ed25519.PublicKey pub) (Ed25519.SecretKey pri)+        _otherwise ->+          expected "valid key type" (Just tag)+    where+      dec :: JSValue -> m (String, BS.ByteString, BS.ByteString)+      dec obj = do+        tag <- fromJSField obj "keytype"+        val <- fromJSField obj "keyval"+        pub <- fromJSField val "public"+        pri <- fromJSField val "private"+        return (tag, B64.toByteString pub, B64.toByteString pri)++instance Monad m => ToJSON m (PublicKey typ) where+  toJSON key = case key of+      PublicKeyEd25519 pub ->+        enc "ed25519" (Ed25519.unPublicKey pub)+    where+      enc :: String -> BS.ByteString -> m JSValue+      enc tag pub = mkObject [+            ("keytype", return $ JSString tag)+          , ("keyval", mkObject [+                ("public", toJSON (B64.fromByteString pub))+              ])+          ]++instance Monad m => ToJSON m (Some Key)        where toJSON (Some a) = toJSON a+instance Monad m => ToJSON m (Some PublicKey)  where toJSON (Some a) = toJSON a+instance Monad m => ToJSON m (Some KeyType)    where toJSON (Some a) = toJSON a++instance ReportSchemaErrors m => FromJSON m (Some PublicKey) where+  fromJSON enc = do+      (tag, pub) <- dec enc+      case tag of+        "ed25519" -> return . Some $+          PublicKeyEd25519 (Ed25519.PublicKey pub)+        _otherwise ->+          expected "valid key type" (Just tag)+    where+      dec :: JSValue -> m (String, BS.ByteString)+      dec obj = do+        tag <- fromJSField obj "keytype"+        val <- fromJSField obj "keyval"+        pub <- fromJSField val "public"+        return (tag, B64.toByteString pub)++instance Monad m => ToJSON m (KeyType typ) where+  toJSON KeyTypeEd25519 = return $ JSString "ed25519"++instance ReportSchemaErrors m => FromJSON m (Some KeyType) where+  fromJSON enc = do+    tag <- fromJSON enc+    case tag of+      "ed25519"  -> return . Some $ KeyTypeEd25519+      _otherwise -> expected "valid key type" (Just tag)++{-------------------------------------------------------------------------------+  Orphans++  Pre-7.8 (base 4.7) we cannot have Typeable instance for higher-kinded types.+  Instead, here we provide some instance for specific instantiations.+-------------------------------------------------------------------------------}++#if !MIN_VERSION_base(4,7,0)+tyConKey, tyConPublicKey, tyConPrivateKey :: Typeable.TyCon+tyConKey        = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "Key"+tyConPublicKey  = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PublicKey"+tyConPrivateKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PrivateKey"++instance Typeable (Some Key) where+  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConKey []]++instance Typeable (Some PublicKey) where+  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPublicKey []]++instance Typeable (Some PrivateKey) where+  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPrivateKey []]+#endif
+ hackage-security/hackage-security/src/Hackage/Security/Key/Env.hs view
@@ -0,0 +1,90 @@+module Hackage.Security.Key.Env (+    KeyEnv -- opaque+  , keyEnvMap+    -- * Convenience constructors+  , fromPublicKeys+  , fromKeys+    -- * The usual accessors+  , empty+  , null+  , insert+  , lookup+  , union+  ) where++import Prelude hiding (lookup, null)+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map++import Hackage.Security.Key+import Hackage.Security.Util.JSON+import Hackage.Security.Util.Some++{-------------------------------------------------------------------------------+  Main datatype+-------------------------------------------------------------------------------}++-- | A key environment is a mapping from key IDs to the corresponding keys.+--+-- It should satisfy the invariant that these key IDs actually match the keys;+-- see 'checkKeyEnvInvariant'.+newtype KeyEnv = KeyEnv {+    keyEnvMap :: Map KeyId (Some PublicKey)+  }+  deriving (Show)++-- | Verify that each key ID is mapped to a key with that ID+checkKeyEnvInvariant :: KeyEnv -> Bool+checkKeyEnvInvariant = all (uncurry go) . Map.toList . keyEnvMap+  where+    go :: KeyId -> Some PublicKey -> Bool+    go kId key = kId == someKeyId key++{-------------------------------------------------------------------------------+  Convenience constructors+-------------------------------------------------------------------------------}++fromPublicKeys :: [Some PublicKey] -> KeyEnv+fromPublicKeys = KeyEnv . Map.fromList . map aux+  where+    aux :: Some PublicKey -> (KeyId, Some PublicKey)+    aux pub = (someKeyId pub, pub)++fromKeys :: [Some Key] -> KeyEnv+fromKeys = fromPublicKeys . map somePublicKey++{-------------------------------------------------------------------------------+  The usual accessors+-------------------------------------------------------------------------------}++empty :: KeyEnv+empty = KeyEnv Map.empty++null :: KeyEnv -> Bool+null (KeyEnv env) = Map.null env++insert :: Some PublicKey -> KeyEnv -> KeyEnv+insert key (KeyEnv env) = KeyEnv $ Map.insert (someKeyId key) key env++lookup :: KeyId -> KeyEnv -> Maybe (Some PublicKey)+lookup kId (KeyEnv env) = Map.lookup kId env++union :: KeyEnv -> KeyEnv -> KeyEnv+union (KeyEnv env) (KeyEnv env') = KeyEnv (env `Map.union` env')++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m KeyEnv where+  toJSON (KeyEnv keyEnv) = toJSON keyEnv++instance ReportSchemaErrors m => FromJSON m KeyEnv where+  fromJSON enc = do+    keyEnv <- KeyEnv <$> fromJSON enc+    -- We should really use 'validate', but that causes module import cycles.+    -- Sigh.+    unless (checkKeyEnvInvariant keyEnv) $+      expected "valid key environment" Nothing+    return keyEnv
+ hackage-security/hackage-security/src/Hackage/Security/Server.hs view
@@ -0,0 +1,29 @@+-- | Main entry point into the Hackage Security framework for clients+module Hackage.Security.Server (+    -- * Re-exports+    module Hackage.Security.JSON+  , module Hackage.Security.Key+  , module Hackage.Security.TUF+  ) where++import Hackage.Security.JSON (+    ToJSON(..)+  , FromJSON(..)+  , DeserializationError(..)+  , ReadJSON_Keys_Layout+  , ReadJSON_Keys_NoLayout+  , ReadJSON_NoKeys_NoLayout+  , parseJSON_Keys_Layout+  , parseJSON_Keys_NoLayout+  , parseJSON_NoKeys_NoLayout+  , readJSON_Keys_Layout+  , readJSON_Keys_NoLayout+  , readJSON_NoKeys_NoLayout+  , WriteJSON+  , renderJSON+  , renderJSON_NoLayout+  , writeJSON+  , writeJSON_NoLayout+  )+import Hackage.Security.Key+import Hackage.Security.TUF
+ hackage-security/hackage-security/src/Hackage/Security/TUF.hs view
@@ -0,0 +1,41 @@+-- | Export all the TUF datatypes+module Hackage.Security.TUF (+    module Hackage.Security.TUF.Common+  , module Hackage.Security.TUF.FileInfo+  , module Hackage.Security.TUF.FileMap+  , module Hackage.Security.TUF.Header+  , module Hackage.Security.TUF.Layout.Cache+  , module Hackage.Security.TUF.Layout.Index+  , module Hackage.Security.TUF.Layout.Repo+  , module Hackage.Security.TUF.Mirrors+  , module Hackage.Security.TUF.Paths+--  , module Hackage.Security.TUF.Patterns+  , module Hackage.Security.TUF.Root+  , module Hackage.Security.TUF.Signed+  , module Hackage.Security.TUF.Snapshot+  , module Hackage.Security.TUF.Targets+  , module Hackage.Security.TUF.Timestamp+  ) where++import Hackage.Security.TUF.Common+import Hackage.Security.TUF.FileInfo+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.Layout.Cache+import Hackage.Security.TUF.Layout.Index+import Hackage.Security.TUF.Layout.Repo+import Hackage.Security.TUF.Mirrors+-- import Hackage.Security.TUF.Patterns+import Hackage.Security.TUF.Paths+import Hackage.Security.TUF.Root+import Hackage.Security.TUF.Signed+import Hackage.Security.TUF.Snapshot+import Hackage.Security.TUF.Targets+import Hackage.Security.TUF.Timestamp++-- FileMap is intended for qualified imports, so we only export a subset+import Hackage.Security.TUF.FileMap (+    FileMap+  , TargetPath(..)+  , FileChange(..)+  , fileMapChanges+  )
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Common.hs view
@@ -0,0 +1,53 @@+-- | Simple type wrappers+module Hackage.Security.TUF.Common (+    -- * Types+    FileLength(..)+  , Hash(..)+  , KeyThreshold(..)+  ) where++import Hackage.Security.JSON++{-------------------------------------------------------------------------------+  Simple types+-------------------------------------------------------------------------------}++-- | File length+--+-- Having verified file length information means we can protect against+-- endless data attacks and similar.+newtype FileLength = FileLength { fileLength :: Int54 }+  deriving (Eq, Ord, Show)++-- | Key threshold+--+-- The key threshold is the minimum number of keys a document must be signed+-- with. Key thresholds are specified in 'RoleSpec' or 'DelegationsSpec'.+newtype KeyThreshold = KeyThreshold Int54+  deriving (Eq, Ord, Show)++-- | File hash+newtype Hash = Hash String+  deriving (Eq, Ord, Show)++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m KeyThreshold where+  toJSON (KeyThreshold i) = toJSON i++instance Monad m => ToJSON m FileLength where+  toJSON (FileLength i) = toJSON i++instance Monad m => ToJSON m Hash where+  toJSON (Hash str) = toJSON str++instance ReportSchemaErrors m => FromJSON m KeyThreshold where+  fromJSON enc = KeyThreshold <$> fromJSON enc++instance ReportSchemaErrors m => FromJSON m FileLength where+  fromJSON enc = FileLength <$> fromJSON enc++instance ReportSchemaErrors m => FromJSON m Hash where+  fromJSON enc = Hash <$> fromJSON enc
+ hackage-security/hackage-security/src/Hackage/Security/TUF/FileInfo.hs view
@@ -0,0 +1,103 @@+-- | Information about files+module Hackage.Security.TUF.FileInfo (+    FileInfo(..)+  , HashFn(..)+  , Hash(..)+    -- * Utility+  , fileInfo+  , computeFileInfo+  , knownFileInfoEqual+  , fileInfoSHA256+    -- ** Re-exports+  , Int54+  ) where++import Prelude hiding (lookup)+import Data.Map (Map)+import qualified Crypto.Hash          as CH+import qualified Data.Map             as Map+import qualified Data.ByteString.Lazy as BS.L++import Hackage.Security.JSON+import Hackage.Security.TUF.Common+import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++data HashFn = HashFnSHA256+  deriving (Show, Eq, Ord)++-- | File information+--+-- This intentionally does not have an 'Eq' instance; see 'knownFileInfoEqual'+-- and 'verifyFileInfo' instead.+--+-- NOTE: Throughout we compute file information always over the raw bytes.+-- For example, when @timestamp.json@ lists the hash of @snapshot.json@, this+-- hash is computed over the actual @snapshot.json@ file (as opposed to the+-- canonical form of the embedded JSON). This brings it in line with the hash+-- computed over target files, where that is the only choice available.+data FileInfo = FileInfo {+    fileInfoLength :: FileLength+  , fileInfoHashes :: Map HashFn Hash+  }+  deriving (Show)++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++-- | Compute 'FileInfo'+--+-- TODO: Currently this will load the entire input bytestring into memory.+-- We need to make this incremental, by computing the length and all hashes+-- in a single traversal over the input.+fileInfo :: BS.L.ByteString -> FileInfo+fileInfo bs = FileInfo {+      fileInfoLength = FileLength . fromIntegral $ BS.L.length bs+    , fileInfoHashes = Map.fromList [+          (HashFnSHA256, Hash $ show (CH.hashlazy bs :: CH.Digest CH.SHA256))+        ]+    }++-- | Compute 'FileInfo'+computeFileInfo :: FsRoot root => Path root -> IO FileInfo+computeFileInfo fp = fileInfo <$> readLazyByteString fp++-- | Compare known file info+--+-- This should be used only when the FileInfo is already known. If we want to+-- compare known FileInfo against a file on disk we should delay until we know+-- have confirmed that the file lengths don't match (see 'verifyFileInfo').+knownFileInfoEqual :: FileInfo -> FileInfo -> Bool+knownFileInfoEqual a b = (==) (fileInfoLength a, fileInfoHashes a)+                              (fileInfoLength b, fileInfoHashes b)++-- | Extract SHA256 hash from 'FileInfo' (if present)+fileInfoSHA256 :: FileInfo -> Maybe Hash+fileInfoSHA256 FileInfo{..} = Map.lookup HashFnSHA256 fileInfoHashes++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToObjectKey m HashFn where+  toObjectKey HashFnSHA256 = return "sha256"++instance ReportSchemaErrors m => FromObjectKey m HashFn where+  fromObjectKey "sha256" = return HashFnSHA256+  fromObjectKey str      = expected "valid hash function" (Just str)++instance Monad m => ToJSON m FileInfo where+  toJSON FileInfo{..} = mkObject [+        ("length", toJSON fileInfoLength)+      , ("hashes", toJSON fileInfoHashes)+      ]++instance ReportSchemaErrors m => FromJSON m FileInfo where+  fromJSON enc = do+    fileInfoLength <- fromJSField enc "length"+    fileInfoHashes <- fromJSField enc "hashes"+    return FileInfo{..}
+ hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs view
@@ -0,0 +1,134 @@+-- | Information about files+--+-- Intended to be double imported+--+-- > import Hackage.Security.TUF.FileMap (FileMap)+-- > import qualified Hackage.Security.TUF.FileMap as FileMap+module Hackage.Security.TUF.FileMap (+    FileMap -- opaque+  , TargetPath(..)+    -- * Standard accessors+  , empty+  , lookup+  , (!)+  , insert+  , fromList+    -- * Convenience accessors+  , lookupM+    -- * Comparing file maps+  , FileChange(..)+  , fileMapChanges+  ) where++import Prelude hiding (lookup)+import Control.Arrow (second)+import Data.Map (Map)+import qualified Data.Map as Map++import Hackage.Security.JSON+import Hackage.Security.TUF.FileInfo+import Hackage.Security.TUF.Paths+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++-- | Mapping from paths to file info+--+-- File maps are used in target files; the paths are relative to the location+-- of the target files containing the file map.+newtype FileMap = FileMap { fileMap :: Map TargetPath FileInfo }+  deriving (Show)++-- | Entries in 'FileMap' either talk about the repository or the index+data TargetPath =+    TargetPathRepo  RepoPath+  | TargetPathIndex IndexPath+  deriving (Show, Eq, Ord)++instance Pretty TargetPath where+  pretty (TargetPathRepo  path) = pretty path+  pretty (TargetPathIndex path) = pretty path++{-------------------------------------------------------------------------------+  Standard accessors+-------------------------------------------------------------------------------}++empty :: FileMap+empty = FileMap Map.empty++lookup :: TargetPath -> FileMap -> Maybe FileInfo+lookup fp = Map.lookup fp . fileMap++(!) :: FileMap -> TargetPath -> FileInfo+fm ! fp = fileMap fm Map.! fp++insert :: TargetPath -> FileInfo -> FileMap -> FileMap+insert fp nfo = FileMap . Map.insert fp nfo . fileMap++fromList :: [(TargetPath, FileInfo)] -> FileMap+fromList = FileMap . Map.fromList++{-------------------------------------------------------------------------------+  Convenience accessors+-------------------------------------------------------------------------------}++lookupM :: Monad m => FileMap -> TargetPath -> m FileInfo+lookupM m fp =+    case lookup fp m of+      Nothing  -> fail $ "No entry for " ++ pretty fp ++ " in filemap"+      Just nfo -> return nfo++{-------------------------------------------------------------------------------+  Comparing filemaps+-------------------------------------------------------------------------------}++data FileChange =+    -- | File got added or modified; we record the new file info+    FileChanged FileInfo++    -- | File got deleted+  | FileDeleted+  deriving (Show)++fileMapChanges :: FileMap  -- ^ Old+               -> FileMap  -- ^ New+               -> Map TargetPath FileChange+fileMapChanges (FileMap a) (FileMap b) =+    Map.fromList $ go (Map.toList a) (Map.toList b)+  where+    -- Assumes the old and new lists are sorted alphabetically+    -- (Map.toList guarantees this)+    go :: [(TargetPath, FileInfo)]+       -> [(TargetPath, FileInfo)]+       -> [(TargetPath, FileChange)]+    go [] new = map (second FileChanged) new+    go old [] = map (second (const FileDeleted)) old+    go old@((fp, nfo):old') new@((fp', nfo'):new')+      | fp < fp'  = (fp , FileDeleted     ) : go old' new+      | fp > fp'  = (fp', FileChanged nfo') : go old  new'+      | knownFileInfoEqual nfo nfo' = (fp , FileChanged nfo') : go old' new'+      | otherwise = go old' new'++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m FileMap where+  toJSON (FileMap metaFiles) = toJSON metaFiles++instance ReportSchemaErrors m => FromJSON m FileMap where+  fromJSON enc = FileMap <$> fromJSON enc++instance Monad m => ToObjectKey m TargetPath where+  toObjectKey = return . pretty++instance ReportSchemaErrors m => FromObjectKey m TargetPath where+  fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) =+    return . TargetPathRepo  . rootPath . fromUnrootedFilePath $ path+  fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) =+    return . TargetPathIndex . rootPath . fromUnrootedFilePath $ path+  fromObjectKey str =+    expected "target path" (Just str)
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Header.hs view
@@ -0,0 +1,119 @@+-- | Header used by all TUF types+module Hackage.Security.TUF.Header (+    HasHeader(..)+  , FileVersion(..)+  , FileExpires(..)+  , Header(..)+    -- ** Utility+  , expiresInDays+  , expiresNever+  , isExpired+  , versionInitial+  , versionIncrement+  ) where++import Data.Time+import Data.Typeable (Typeable)++import Hackage.Security.JSON+import Hackage.Security.Util.Lens++{-------------------------------------------------------------------------------+  TUF header+-------------------------------------------------------------------------------}++class HasHeader a where+  -- | File expiry date+  fileExpires :: Lens' a FileExpires++  -- | File version (monotonically increasing counter)+  fileVersion :: Lens' a FileVersion++-- | File version+--+-- The file version is a flat integer which must monotonically increase on+-- every file update.+--+-- 'Show' and 'Read' instance are defined in terms of the underlying 'Int'+-- (this is use for example by hackage during the backup process).+newtype FileVersion = FileVersion Int54+  deriving (Eq, Ord, Typeable)++instance Show FileVersion where+  show (FileVersion v) = show v++instance Read FileVersion where+  readsPrec p = map (\(v, xs) -> (FileVersion v, xs)) . readsPrec p++-- | File expiry date+--+-- A 'Nothing' value here means no expiry. That makes it possible to set some+-- files to never expire. (Note that not having the Maybe in the type here still+-- allows that, because you could set an expiry date 2000 years into the future.+-- By having the Maybe here we avoid the _need_ for such encoding issues.)+newtype FileExpires = FileExpires (Maybe UTCTime)+  deriving (Eq, Ord, Show, Typeable)++-- | Occassionally it is useful to read only a header from a file.+--+-- 'HeaderOnly' intentionally only has a 'FromJSON' instance (no 'ToJSON').+data Header = Header {+    headerExpires :: FileExpires+  , headerVersion :: FileVersion+  }++instance HasHeader Header where+  fileExpires f x = (\y -> x { headerExpires = y }) <$> f (headerExpires x)+  fileVersion f x = (\y -> x { headerVersion = y }) <$> f (headerVersion x)++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++expiresNever :: FileExpires+expiresNever = FileExpires Nothing++expiresInDays :: UTCTime -> Integer -> FileExpires+expiresInDays now n =+    FileExpires . Just $ addUTCTime (fromInteger n * oneDay) now++isExpired :: UTCTime -> FileExpires -> Bool+isExpired _   (FileExpires Nothing)  = False+isExpired now (FileExpires (Just e)) = e < now++versionInitial :: FileVersion+versionInitial = FileVersion 1++versionIncrement :: FileVersion -> FileVersion+versionIncrement (FileVersion i) = FileVersion (i + 1)++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m FileVersion where+  toJSON (FileVersion i) = toJSON i++instance Monad m => ToJSON m FileExpires where+  toJSON (FileExpires (Just e)) = toJSON e+  toJSON (FileExpires Nothing)  = return JSNull++instance ReportSchemaErrors m => FromJSON m FileVersion where+  fromJSON enc = FileVersion <$> fromJSON enc++instance ReportSchemaErrors m => FromJSON m FileExpires where+  fromJSON JSNull = return $ FileExpires Nothing+  fromJSON enc    = FileExpires . Just <$> fromJSON enc++instance ReportSchemaErrors m => FromJSON m Header where+  fromJSON enc = do+    headerExpires <- fromJSField enc "expires"+    headerVersion <- fromJSField enc "version"+    return Header{..}++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++oneDay :: NominalDiffTime+oneDay = 24 * 60 * 60
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Cache.hs view
@@ -0,0 +1,64 @@+module Hackage.Security.TUF.Layout.Cache (+    -- * Cache layout+    CacheLayout(..)+  , cabalCacheLayout+  ) where++import Hackage.Security.TUF.Paths+import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Cache layout+-------------------------------------------------------------------------------}++-- | Location of the various files we cache+--+-- Although the generic TUF algorithms do not care how we organize the cache,+-- we nonetheless specity this here because as long as there are tools which+-- access files in the cache directly we need to define the cache layout.+-- See also comments for 'defaultCacheLayout'.+data CacheLayout = CacheLayout {+    -- | TUF root metadata+    cacheLayoutRoot :: CachePath++    -- | TUF timestamp+  , cacheLayoutTimestamp :: CachePath++    -- | TUF snapshot+  , cacheLayoutSnapshot :: CachePath++    -- | TUF mirrors list+  , cacheLayoutMirrors :: CachePath++    -- | Uncompressed index tarball+  , cacheLayoutIndexTar :: CachePath++    -- | Index to the uncompressed index tarball+  , cacheLayoutIndexIdx :: CachePath++    -- | Compressed index tarball+    --+    -- We cache both the compressed and the uncompressed tarballs, because+    -- incremental updates happen through the compressed tarball, but reads+    -- happen through the uncompressed one (with the help of the tarball index).+  , cacheLayoutIndexTarGz :: CachePath+  }++-- | The cache layout cabal-install uses+--+-- We cache the index as @<cache>/00-index.tar@; this is important because+-- `cabal-install` expects to find it there (and does not currently go through+-- the hackage-security library to get files from the index).+cabalCacheLayout :: CacheLayout+cabalCacheLayout = CacheLayout {+      cacheLayoutRoot       = rp $ fragment "root.json"+    , cacheLayoutTimestamp  = rp $ fragment "timestamp.json"+    , cacheLayoutSnapshot   = rp $ fragment "snapshot.json"+    , cacheLayoutMirrors    = rp $ fragment "mirrors.json"+    , cacheLayoutIndexTar   = rp $ fragment "00-index.tar"+    , cacheLayoutIndexIdx   = rp $ fragment "00-index.tar.idx"+    , cacheLayoutIndexTarGz = rp $ fragment "00-index.tar.gz"+    }+  where+    rp :: Path Unrooted -> CachePath+    rp = rootPath
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Index.hs view
@@ -0,0 +1,116 @@+module Hackage.Security.TUF.Layout.Index (+    -- * Repository layout+    IndexLayout(..)+  , IndexFile(..)+  , hackageIndexLayout+    -- ** Utility+  , indexLayoutPkgMetadata+  , indexLayoutPkgCabal+  , indexLayoutPkgPrefs+  ) where++import qualified System.FilePath as FP++import Distribution.Package+import Distribution.Text++import Hackage.Security.TUF.Paths+import Hackage.Security.TUF.Signed+import Hackage.Security.TUF.Targets+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import Hackage.Security.Util.Some++{-------------------------------------------------------------------------------+  Index layout+-------------------------------------------------------------------------------}++-- | Layout of the files within the index tarball+data IndexLayout = IndexLayout  {+      -- | Translate an 'IndexFile' to a path+      indexFileToPath :: forall dec. IndexFile dec -> IndexPath++      -- | Parse an 'FilePath'+    , indexFileFromPath :: IndexPath -> Maybe (Some IndexFile)+    }++-- | Files that we might request from the index+--+-- The type index tells us the type of the decoded file, if any. For files for+-- which the library does not support decoding this will be @()@.+-- NOTE: Clients should NOT rely on this type index being @()@, or they might+-- break if we add support for parsing additional file formats in the future.+--+-- TODO: If we wanted to support legacy Hackage, we should also have a case for+-- the global preferred-versions file. But supporting legacy Hackage will+-- probably require more work anyway..+data IndexFile :: * -> * where+    -- | Package-specific metadata (@targets.json@)+    IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets)++    -- | Cabal file for a package+    IndexPkgCabal :: PackageIdentifier -> IndexFile ()++    -- | Preferred versions a package+    IndexPkgPrefs :: PackageName -> IndexFile ()++deriving instance Show (IndexFile dec)++instance Pretty (IndexFile dec) where+  pretty (IndexPkgMetadata pkgId) = "metadata for " ++ display pkgId+  pretty (IndexPkgCabal    pkgId) = ".cabal for " ++ display pkgId+  pretty (IndexPkgPrefs    pkgNm) = "preferred-versions for " ++ display pkgNm++instance SomeShow   IndexFile where someShow   = DictShow+instance SomePretty IndexFile where somePretty = DictPretty++-- | The layout of the index as maintained on Hackage+hackageIndexLayout :: IndexLayout+hackageIndexLayout = IndexLayout {+      indexFileToPath   = toPath+    , indexFileFromPath = fromPath . toUnrootedFilePath . unrootPath+    }+  where+    toPath :: IndexFile dec -> IndexPath+    toPath (IndexPkgCabal    pkgId) = fromFragments [+                                          display (packageName    pkgId)+                                        , display (packageVersion pkgId)+                                        , display (packageName pkgId) ++ ".cabal"+                                        ]+    toPath (IndexPkgMetadata pkgId) = fromFragments [+                                          display (packageName    pkgId)+                                        , display (packageVersion pkgId)+                                        , "package.json"+                                        ]+    toPath (IndexPkgPrefs    pkgNm) = fromFragments [+                                          display pkgNm+                                        , "preferred-versions"+                                        ]++    fromFragments :: [String] -> IndexPath+    fromFragments = rootPath . joinFragments++    fromPath :: FilePath -> Maybe (Some IndexFile)+    fromPath fp = case FP.splitPath fp of+      [pkg, version, file] -> do+        pkgId <- simpleParse (init pkg ++ "-" ++ init version)+        case FP.takeExtension file of+          ".cabal"   -> return $ Some $ IndexPkgCabal    pkgId+          ".json"    -> return $ Some $ IndexPkgMetadata pkgId+          _otherwise -> Nothing+      [pkg, "preferred-versions"] ->+        Some . IndexPkgPrefs <$> simpleParse (init pkg)+      _otherwise -> Nothing++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++indexLayoutPkgMetadata :: IndexLayout -> PackageIdentifier -> IndexPath+indexLayoutPkgMetadata IndexLayout{..} = indexFileToPath . IndexPkgMetadata++indexLayoutPkgCabal :: IndexLayout -> PackageIdentifier -> IndexPath+indexLayoutPkgCabal IndexLayout{..} = indexFileToPath . IndexPkgCabal++indexLayoutPkgPrefs :: IndexLayout -> PackageName -> IndexPath+indexLayoutPkgPrefs IndexLayout{..} = indexFileToPath . IndexPkgPrefs
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Layout/Repo.hs view
@@ -0,0 +1,79 @@+module Hackage.Security.TUF.Layout.Repo (+    -- * Repository layout+    RepoLayout(..)+  , hackageRepoLayout+  , cabalLocalRepoLayout+  ) where++import Distribution.Package+import Distribution.Text++import Hackage.Security.TUF.Paths+import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Repository layout+-------------------------------------------------------------------------------}++-- | Layout of a repository+data RepoLayout = RepoLayout {+      -- | TUF root metadata+      repoLayoutRoot :: RepoPath++      -- | TUF timestamp+    , repoLayoutTimestamp :: RepoPath++      -- | TUF snapshot+    , repoLayoutSnapshot :: RepoPath++      -- | TUF mirrors list+    , repoLayoutMirrors :: RepoPath++      -- | Compressed index tarball+    , repoLayoutIndexTarGz :: RepoPath++      -- | Uncompressed index tarball+    , repoLayoutIndexTar :: RepoPath++      -- | Path to the package tarball+    , repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath+    }++-- | The layout used on Hackage+hackageRepoLayout :: RepoLayout+hackageRepoLayout = RepoLayout {+      repoLayoutRoot       = rp $ fragment "root.json"+    , repoLayoutTimestamp  = rp $ fragment "timestamp.json"+    , repoLayoutSnapshot   = rp $ fragment "snapshot.json"+    , repoLayoutMirrors    = rp $ fragment "mirrors.json"+    , repoLayoutIndexTarGz = rp $ fragment "01-index.tar.gz"+    , repoLayoutIndexTar   = rp $ fragment "01-index.tar"+    , repoLayoutPkgTarGz   = \pkgId -> rp $ fragment "package" </> pkgFile pkgId+    }+  where+    pkgFile :: PackageIdentifier -> Path Unrooted+    pkgFile pkgId = fragment (display pkgId) <.> "tar.gz"++    rp :: Path Unrooted -> RepoPath+    rp = rootPath++-- | Layout used by cabal for ("legacy") local repos+--+-- Obviously, such repos do not normally contain any of the TUF files, so their+-- location is more or less arbitrary here.+cabalLocalRepoLayout :: RepoLayout+cabalLocalRepoLayout = hackageRepoLayout {+      repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId </> pkgFile pkgId+    }+  where+    pkgLoc :: PackageIdentifier -> Path Unrooted+    pkgLoc pkgId = joinFragments [+          display (packageName    pkgId)+        , display (packageVersion pkgId)+        ]++    pkgFile :: PackageIdentifier -> Path Unrooted+    pkgFile pkgId = fragment (display pkgId) <.> "tar.gz"++    rp :: Path Unrooted -> RepoPath+    rp = rootPath
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Mirrors.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE UndecidableInstances #-}+module Hackage.Security.TUF.Mirrors (+    -- * TUF types+    Mirrors(..)+  , Mirror(..)+  , MirrorContent(..)+    -- ** Utility+  , MirrorDescription+  , describeMirror+  ) where++import Control.Monad.Except+import Network.URI++import Hackage.Security.JSON+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.Signed++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++data Mirrors = Mirrors {+    mirrorsVersion :: FileVersion+  , mirrorsExpires :: FileExpires+  , mirrorsMirrors :: [Mirror]+  }++-- | Definition of a mirror+--+-- NOTE: Unlike the TUF specification, we require that all mirrors must have+-- the same format. That is, we omit @metapath@ and @targetspath@.+data Mirror = Mirror {+    mirrorUrlBase :: URI+  , mirrorContent :: MirrorContent+  }+  deriving Show++-- | Full versus partial mirrors+--+-- The TUF spec explicitly allows for partial mirrors, with the mirrors file+-- specifying (through patterns) what is available from partial mirrors.+--+-- For now we only support full mirrors; if we wanted to add partial mirrors,+-- we would add a second @MirrorPartial@ constructor here with arguments+-- corresponding to TUF's @metacontent@ and @targetscontent@ fields.+data MirrorContent =+    MirrorFull+  deriving Show++instance HasHeader Mirrors where+  fileVersion f x = (\y -> x { mirrorsVersion = y }) <$> f (mirrorsVersion x)+  fileExpires f x = (\y -> x { mirrorsExpires = y }) <$> f (mirrorsExpires x)++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++type MirrorDescription = String++-- | Give a human-readable description of a particular mirror+--+-- (for use in error messages)+describeMirror :: Mirror -> MirrorDescription+describeMirror = show . mirrorUrlBase++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m Mirror where+  toJSON Mirror{..} = mkObject $ concat [+      [ ("urlbase", toJSON mirrorUrlBase) ]+    , case mirrorContent of+        MirrorFull -> []+    ]++instance Monad m => ToJSON m Mirrors where+  toJSON Mirrors{..} = mkObject [+      ("_type"   , return $ JSString "Mirrorlist")+    , ("version" , toJSON mirrorsVersion)+    , ("expires" , toJSON mirrorsExpires)+    , ("mirrors" , toJSON mirrorsMirrors)+    ]++instance ReportSchemaErrors m => FromJSON m Mirror where+  fromJSON enc = do+    mirrorUrlBase <- fromJSField enc "urlbase"+    let mirrorContent = MirrorFull+    return Mirror{..}++instance ( MonadError DeserializationError m+         , ReportSchemaErrors m+         ) => FromJSON m Mirrors where+  fromJSON enc = do+    verifyType enc "Mirrorlist"+    mirrorsVersion <- fromJSField enc "version"+    mirrorsExpires <- fromJSField enc "expires"+    mirrorsMirrors <- fromJSField enc "mirrors"+    return Mirrors{..}++instance MonadKeys m => FromJSON m (Signed Mirrors) where+  fromJSON = signedFromJSON
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Paths.hs view
@@ -0,0 +1,72 @@+-- | Paths used in the TUF data structures+module Hackage.Security.TUF.Paths (+    -- * Repository+    RepoRoot+  , RepoPath+  , anchorRepoPathLocally+  , anchorRepoPathRemotely+    -- * Index+  , IndexRoot+  , IndexPath+    -- * Cache+  , CacheRoot+  , CachePath+  , anchorCachePath+  ) where++import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty++{-------------------------------------------------------------------------------+  Repo+-------------------------------------------------------------------------------}++-- | The root of the repository+--+-- Repository roots can be anchored at a remote URL or a local directory.+--+-- Note that even for remote repos 'RepoRoot' is (potentially) different from+-- 'Web' -- for a repository located at, say, @http://hackage.haskell.org@+-- they happen to coincide, but for one location at+-- @http://example.com/some/subdirectory@ they do not.+data RepoRoot++-- | Paths relative to the root of the repository+type RepoPath = Path RepoRoot++instance Pretty (Path RepoRoot) where+  pretty (Path fp) = "<repo>/" ++ fp++anchorRepoPathLocally :: FsRoot root => Path root -> RepoPath -> Path root+anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath repoPath++anchorRepoPathRemotely :: Path Web -> RepoPath -> Path Web+anchorRepoPathRemotely remoteRoot repoPath = remoteRoot </> unrootPath repoPath++{-------------------------------------------------------------------------------+  Index+-------------------------------------------------------------------------------}++-- | The root of the index tarball+data IndexRoot++-- | Paths relative to the root of the index tarball+type IndexPath = Path IndexRoot++instance Pretty (Path IndexRoot) where+    pretty (Path fp) = "<index>/" ++ fp++{-------------------------------------------------------------------------------+  Cache+-------------------------------------------------------------------------------}++-- | The cache directory+data CacheRoot+type CachePath = Path CacheRoot++instance Pretty (Path CacheRoot) where+    pretty (Path fp) = "<cache>/" ++ fp++-- | Anchor a cache path to the location of the cache+anchorCachePath :: FsRoot root => Path root -> CachePath -> Path root+anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath cachePath
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Patterns.hs view
@@ -0,0 +1,346 @@+-- | Patterns and replacements+--+-- NOTE: This module was developed to prepare for proper delegation (#39).+-- It is currently unusued.+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif+module Hackage.Security.TUF.Patterns (+    -- * Patterns and replacements+    FileName+  , Directory+  , Extension+  , BaseName+  , Pattern(..)+  , Replacement(..)+  , Delegation(..)+    -- ** Utility+  , identityReplacement+  , matchDelegation+    -- ** Parsing and quasi-quoting+  , parseDelegation+  , qqd+  ) where++import Control.Monad.Except+import Language.Haskell.TH (Q, Exp)+import System.FilePath+import qualified Language.Haskell.TH.Syntax as TH++import Hackage.Security.JSON+import Hackage.Security.Util.Some+import Hackage.Security.Util.Stack+import Hackage.Security.Util.TypedEmbedded++{-------------------------------------------------------------------------------+  Patterns and replacements+-------------------------------------------------------------------------------}++type FileName  = String+type Directory = String+type Extension = String+type BaseName  = String++-- | Structured patterns over paths+--+-- The type argument indicates what kind of function we expect when the+-- pattern matches. For example, we have the pattern @"*/*.txt"@:+--+-- > PathPatternDirAny (PathPatternFileExt ".txt")+-- >   :: PathPattern (Directory :- BaseName :- ())+--+-- TODOs (see README.md):+--+-- * Update this to work with 'Path' rather than 'FilePath'/'String'+-- * Add different kinds of wildcards+-- * Add path roots+--+-- Currently this is a proof of concept more than anything else; the right+-- structure is here, but it needs updating. However, until we add author+-- signing (or out-of-tarball targets) we don't actually use this yet.+--+-- NOTE: Haddock lacks GADT support so constructors have only regular comments.+data Pattern a where+    -- Match against a specific filename+    PatFileConst :: FileName -> Pattern ()++    -- Match against a filename with the given extension+    PatFileExt :: Extension -> Pattern (BaseName :- ())++    -- Match against any filename+    PatFileAny :: Pattern (FileName :- ())++    -- Match against a specific directory+    PatDirConst :: Directory -> Pattern a -> Pattern a++    -- Match against any directory+    PatDirAny :: Pattern a -> Pattern (Directory :- a)++-- | Replacement patterns+--+-- These constructors match the ones in 'Pattern': wildcards must be used+-- in the same order as they appear in the pattern, but they don't all have to+-- be used (that's why the base constructors are polymorphic in the stack tail).+data Replacement a where+    RepFileConst :: FileName -> Replacement a+    RepFileExt   :: Extension -> Replacement (BaseName :- a)+    RepFileAny   :: Replacement (FileName :- a)+    RepDirConst  :: Directory -> Replacement a -> Replacement a+    RepDirAny    :: Replacement a -> Replacement (Directory :- a)++deriving instance Eq   (Pattern typ)+deriving instance Show (Pattern typ)++deriving instance Eq   (Replacement typ)+deriving instance Show (Replacement typ)++-- | The identity replacement replaces a matched pattern with itself+identityReplacement :: Pattern typ -> Replacement typ+identityReplacement = go+  where+    go :: Pattern typ -> Replacement typ+    go (PatFileConst fn)  = RepFileConst fn+    go (PatFileExt   e)   = RepFileExt   e+    go PatFileAny         = RepFileAny+    go (PatDirConst  d p) = RepDirConst  d (go p)+    go (PatDirAny      p) = RepDirAny      (go p)++-- | A delegation+--+-- A delegation is a pair of a pattern and a replacement.+--+-- See 'match' for an example.+data Delegation = forall a. Delegation (Pattern a) (Replacement a)++deriving instance Show Delegation++{-------------------------------------------------------------------------------+  Matching+-------------------------------------------------------------------------------}++matchPattern :: String -> Pattern a -> Maybe a+matchPattern = go . splitDirectories+  where+    go :: [String] -> Pattern a -> Maybe a+    go []    _                    = Nothing+    go [f]   (PatFileConst f')    = do guard (f == f')+                                       return ()+    go [f]   (PatFileExt   e')    = do let (bn, _:e) = splitExtension f+                                       guard $ e == e'+                                       return (bn :- ())+    go [_]   _                    = Nothing+    go (d:p) (PatDirConst  d' p') = do guard (d == d')+                                       go p p'+    go (d:p) (PatDirAny       p') = (d :-) <$> go p p'+    go (_:_) _                    = Nothing++constructReplacement :: Replacement a -> a -> String+constructReplacement = \repl a -> joinPath $ go repl a+  where+    go :: Replacement a -> a -> [String]+    go (RepFileConst c)   _         = [c]+    go (RepFileExt   e)   (bn :- _) = [bn <.> e]+    go RepFileAny         (fn :- _) = [fn]+    go (RepDirConst  d p) a         = d : go p a+    go (RepDirAny      p) (d  :- a) = d : go p a++matchDelegation :: Delegation -> String -> Maybe String+matchDelegation (Delegation pat repl) str =+    constructReplacement repl <$> matchPattern str pat++{-------------------------------------------------------------------------------+  Typechecking patterns and replacements+-------------------------------------------------------------------------------}++-- | Types for pattern and replacements+--+-- We intentially are not very precise here, saying @String@ (instead of+-- @FileName@, @BaseName@, or @Directory@, say) so that we can, for example,+-- use a matched filename in a pattern as a directory in a replacement.+data PatternType a where+  PatTypeNil :: PatternType ()+  PatTypeStr :: PatternType a -> PatternType (String :- a)++instance Unify PatternType where+  unify PatTypeNil     PatTypeNil       = Just Refl+  unify (PatTypeStr p) (PatTypeStr  p') = case unify p p' of+                                            Just Refl -> Just Refl+                                            Nothing   -> Nothing+  unify _              _                = Nothing++type instance TypeOf Pattern     = PatternType+type instance TypeOf Replacement = PatternType++instance Typed Pattern where+  typeOf (PatFileConst _)   = PatTypeNil+  typeOf (PatFileExt   _)   = PatTypeStr PatTypeNil+  typeOf (PatFileAny    )   = PatTypeStr PatTypeNil+  typeOf (PatDirConst  _ p) = typeOf p+  typeOf (PatDirAny      p) = PatTypeStr (typeOf p)++instance AsType Replacement where+  asType = go+    where+      go :: Replacement typ -> PatternType typ' -> Maybe (Replacement typ')+      go (RepFileConst c)   _                = return $ RepFileConst c+      go (RepFileExt   _)   PatTypeNil       = Nothing+      go (RepFileExt   e)   (PatTypeStr _)   = return $ RepFileExt e+      go RepFileAny         PatTypeNil       = Nothing+      go RepFileAny         (PatTypeStr _)   = return $ RepFileAny+      go (RepDirConst  c p) tp               = RepDirConst c <$> go p tp+      go (RepDirAny      _) PatTypeNil       = Nothing+      go (RepDirAny      p) (PatTypeStr tp)  = RepDirAny     <$> go p tp++{-------------------------------------------------------------------------------+  Pretty-printing and parsing patterns and replacements+-------------------------------------------------------------------------------}++prettyPattern :: Pattern typ -> String+prettyPattern (PatFileConst f)   = f+prettyPattern (PatFileExt   e)   = "*" <.> e+prettyPattern PatFileAny         = "*"+prettyPattern (PatDirConst  d p) = d   </> prettyPattern p+prettyPattern (PatDirAny      p) = "*" </> prettyPattern p++prettyReplacement :: Replacement typ -> String+prettyReplacement (RepFileConst f)   = f+prettyReplacement (RepFileExt   e)   = "*" <.> e+prettyReplacement RepFileAny         = "*"+prettyReplacement (RepDirConst  d p) = d   </> prettyReplacement p+prettyReplacement (RepDirAny      p) = "*" </> prettyReplacement p++-- | Parse a pattern+parsePattern :: String -> Maybe (Some Pattern)+parsePattern = go . splitDirectories+  where+    go :: [String] -> Maybe (Some Pattern)+    go []     = Nothing+    go ["*"]  = return . Some $ PatFileAny+    go [p]    = if '*' `notElem` p+                  then return . Some $ PatFileConst p+                  else case splitExtension p of+                         ("*", _:ext) -> return . Some $ PatFileExt ext+                         _otherwise   -> Nothing+    go (p:ps) = do Some p' <- go ps+                   if '*' `notElem` p+                     then return . Some $ PatDirConst p p'+                     else case p of+                            "*"        -> return . Some $ PatDirAny p'+                            _otherwise -> Nothing++-- | Parse a replacement+--+-- We cheat and use the parser for patterns and then translate using the+-- identity replacement.+parseReplacement :: String -> Maybe (Some Replacement)+parseReplacement = fmap aux . parsePattern+  where+    aux :: Some Pattern -> Some Replacement+    aux (Some pat) = Some (identityReplacement pat)++parseDelegation :: String -> String -> Either String Delegation+parseDelegation pat repl =+    case (parsePattern pat, parseReplacement repl) of+      (Just (Some pat'), Just (Some repl')) ->+        case repl' `asType` typeOf pat' of+          Just repl'' -> Right $ Delegation pat' repl''+          Nothing     -> Left "Replacement does not match pattern type"+      _otherwise ->+        Left "Cannot parse delegation"++{-------------------------------------------------------------------------------+  Quasi-quotation++  We cannot (easily) use dataToExpQ because of the use of GADTs, so we manually+  give Lift instances.+-------------------------------------------------------------------------------}++-- | Quasi-quoter for delegations to make them easier to write in code+--+-- This allows to write delegations as+--+-- > $(qqd "targets/*/*/*.cabal" "targets/*/*/revisions.json")+--+-- (The alternative syntax which actually uses a quasi-quoter doesn't work very+-- well because the '/*' bits confuse CPP: "unterminated comment")+qqd :: String -> String -> Q Exp+qqd pat repl  =+    case parseDelegation pat repl of+      Left  err -> fail $ "Invalid delegation: " ++ err+      Right del -> TH.lift del++instance TH.Lift (Pattern a) where+  lift (PatFileConst fn)  = [| PatFileConst fn  |]+  lift (PatFileExt   e)   = [| PatFileExt   e   |]+  lift PatFileAny         = [| PatFileAny       |]+  lift (PatDirConst  d p) = [| PatDirConst  d p |]+  lift (PatDirAny      p) = [| PatDirAny      p |]++instance TH.Lift (Replacement a) where+  lift (RepFileConst fn)  = [| RepFileConst fn  |]+  lift (RepFileExt   e )  = [| RepFileExt   e   |]+  lift RepFileAny         = [| RepFileAny       |]+  lift (RepDirConst  d r) = [| RepDirConst  d r |]+  lift (RepDirAny      r) = [| RepDirAny      r |]++instance TH.Lift Delegation where+  lift (Delegation pat repl) = [| Delegation pat repl |]++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m (Pattern typ) where+  toJSON = return . JSString . prettyPattern+instance Monad m => ToJSON m (Replacement typ) where+  toJSON = return . JSString . prettyReplacement++instance Monad m => ToJSON m (Some Pattern) where+  toJSON (Some p) = toJSON p+instance Monad m => ToJSON m (Some Replacement) where+  toJSON (Some r) = toJSON r++instance ReportSchemaErrors m => FromJSON m (Some Pattern) where+  fromJSON enc = do+    str <- fromJSON enc+    case parsePattern str of+      Nothing -> expected "valid pattern" (Just str)+      Just p  -> return p++instance ReportSchemaErrors m => FromJSON m (Some Replacement) where+  fromJSON enc = do+    str <- fromJSON enc+    case parseReplacement str of+      Nothing -> expected "valid replacement" (Just str)+      Just r  -> return r++{-------------------------------------------------------------------------------+  Debugging: examples+-------------------------------------------------------------------------------}++_ex1 :: Maybe String+_ex1 = matchDelegation del "A/x/y/z.foo"+  where+    del = Delegation+            ( PatDirConst "A"+            $ PatDirAny+            $ PatDirAny+            $ PatFileExt "foo"+            )+            ( RepDirConst "B"+            $ RepDirAny+            $ RepDirConst "C"+            $ RepDirAny+            $ RepFileExt "bar"+            )++_ex2 :: Maybe String+_ex2 = matchDelegation del "A/x/y/z.foo"+  where+    Right del = parseDelegation "A/*/*/*.foo" "B/*/C/*/*.bar"++_ex3 :: Either String Delegation+_ex3 = parseDelegation "foo" "*/bar"
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Root.hs view
@@ -0,0 +1,117 @@+-- | The root filetype+module Hackage.Security.TUF.Root (+    -- * Datatypes+    Root(..)+  , RootRoles(..)+  , RoleSpec(..)+  ) where++import Hackage.Security.JSON+import Hackage.Security.Key+import Hackage.Security.Key.Env (KeyEnv)+import Hackage.Security.TUF.Common+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.Mirrors+import Hackage.Security.TUF.Signed+import Hackage.Security.TUF.Snapshot+import Hackage.Security.TUF.Targets+import Hackage.Security.TUF.Timestamp+import Hackage.Security.Util.Some++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++-- | The root metadata+--+-- NOTE: We must have the invariant that ALL keys (apart from delegation keys)+-- must be listed in 'rootKeys'. (Delegation keys satisfy a similar invariant,+-- see Targets.)+data Root = Root {+    rootVersion :: FileVersion+  , rootExpires :: FileExpires+  , rootKeys    :: KeyEnv+  , rootRoles   :: RootRoles+  }++data RootRoles = RootRoles {+    rootRolesRoot      :: RoleSpec Root+  , rootRolesSnapshot  :: RoleSpec Snapshot+  , rootRolesTargets   :: RoleSpec Targets+  , rootRolesTimestamp :: RoleSpec Timestamp+  , rootRolesMirrors   :: RoleSpec Mirrors+  }++-- | Role specification+--+-- The phantom type indicates what kind of type this role is meant to verify.+data RoleSpec a = RoleSpec {+    roleSpecKeys      :: [Some PublicKey]+  , roleSpecThreshold :: KeyThreshold+  }+  deriving (Show)++instance HasHeader Root where+  fileVersion f x = (\y -> x { rootVersion = y }) <$> f (rootVersion x)+  fileExpires f x = (\y -> x { rootExpires = y }) <$> f (rootExpires x)++{-------------------------------------------------------------------------------+  JSON encoding+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m RootRoles where+  toJSON RootRoles{..} = mkObject [+      ("root"      , toJSON rootRolesRoot)+    , ("snapshot"  , toJSON rootRolesSnapshot)+    , ("targets"   , toJSON rootRolesTargets)+    , ("timestamp" , toJSON rootRolesTimestamp)+    , ("mirrors"   , toJSON rootRolesMirrors)+    ]++instance MonadKeys m => FromJSON m RootRoles where+  fromJSON enc = do+    rootRolesRoot      <- fromJSField enc "root"+    rootRolesSnapshot  <- fromJSField enc "snapshot"+    rootRolesTargets   <- fromJSField enc "targets"+    rootRolesTimestamp <- fromJSField enc "timestamp"+    rootRolesMirrors   <- fromJSField enc "mirrors"+    return RootRoles{..}++instance Monad m => ToJSON m Root where+  toJSON Root{..} = mkObject [+         ("_type"   , return $ JSString "Root")+       , ("version" , toJSON rootVersion)+       , ("expires" , toJSON rootExpires)+       , ("keys"    , toJSON rootKeys)+       , ("roles"   , toJSON rootRoles)+       ]++instance Monad m => ToJSON m (RoleSpec a) where+  toJSON RoleSpec{..} = mkObject [+        ("keyids"    , return . JSArray . map writeKeyAsId $ roleSpecKeys)+      , ("threshold" , toJSON roleSpecThreshold)+      ]++-- | We give an instance for Signed Root rather than Root because the key+-- environment from the root data is necessary to resolve the explicit sharing+-- in the signatures.+instance MonadKeys m => FromJSON m (Signed Root) where+  fromJSON envelope = do+    enc      <- fromJSField envelope "signed"+    rootKeys <- fromJSField enc      "keys"+    withKeys rootKeys $ do+      verifyType enc "Root"+      rootVersion <- fromJSField enc "version"+      rootExpires <- fromJSField enc "expires"+      rootRoles   <- fromJSField enc "roles"+      let signed = Root{..}++      signatures <- fromJSField envelope "signatures"+      validate "signatures" $ verifySignatures enc signatures+      return Signed{..}++instance MonadKeys m => FromJSON m (RoleSpec a) where+  fromJSON enc = do+    roleSpecKeys      <- mapM readKeyAsId =<< fromJSField enc "keyids"+    roleSpecThreshold <- fromJSField enc "threshold"+    return RoleSpec{..}
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Signed.hs view
@@ -0,0 +1,238 @@+-- | Wrapper around an arbitrary datatype that adds signatures+--+-- Note that in the spec there is explicit sharing of keys through key IDs;+-- we translate this to implicit sharing in our Haskell datatypes, with the+-- translation done in the JSON serialization/deserialization.+module Hackage.Security.TUF.Signed (+    -- * TUF types+    Signed(..)+  , Signatures(..)+  , Signature(..)+    -- * Construction and verification+  , unsigned+  , withSignatures+  , withSignatures'+  , signRendered+  , verifySignature+    -- * JSON aids+  , signedFromJSON+  , verifySignatures+    -- * Avoid interpreting signatures+  , UninterpretedSignatures(..)+  , PreSignature(..)+    -- ** Utility+  , fromPreSignature+  , fromPreSignatures+  , toPreSignature+  , toPreSignatures+  ) where++import Control.Monad+import Data.Functor.Identity+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BS.L+import qualified Data.Set             as Set++import Hackage.Security.JSON+import Hackage.Security.Key+import Hackage.Security.TUF.Layout.Repo+import Hackage.Security.Util.Some+import Text.JSON.Canonical+import qualified Hackage.Security.Util.Base64 as B64++{-------------------------------------------------------------------------------+  Signed objects+-------------------------------------------------------------------------------}++data Signed a = Signed {+    signed     :: a+  , signatures :: Signatures+  }++-- | A list of signatures+--+-- Invariant: each signature must be made with a different key.+-- We enforce this invariant for incoming untrusted data ('fromPreSignatures')+-- but not for lists of signatures that we create in code.+newtype Signatures = Signatures [Signature]++data Signature = Signature {+    signature    :: BS.ByteString+  , signatureKey :: Some PublicKey+  }++-- | Create a new document without any signatures+unsigned :: a -> Signed a+unsigned a = Signed { signed = a, signatures = Signatures [] }++-- | Sign a document+withSignatures :: ToJSON WriteJSON a => RepoLayout -> [Some Key] -> a -> Signed a+withSignatures repoLayout keys doc = Signed {+      signed     = doc+    , signatures = signRendered keys $ renderJSON repoLayout doc+    }++-- | Variation on 'withSignatures' that doesn't need the repo layout+withSignatures' :: ToJSON Identity a => [Some Key] -> a -> Signed a+withSignatures' keys doc = Signed {+      signed     = doc+    , signatures = signRendered keys $ renderJSON_NoLayout doc+    }++-- | Construct signatures for already rendered value+signRendered :: [Some Key] -> BS.L.ByteString -> Signatures+signRendered keys rendered = Signatures $ map go keys+  where+    go :: Some Key -> Signature+    go (Some key) = Signature {+        signature    = sign (privateKey key) rendered+      , signatureKey = Some $ publicKey key+      }++verifySignature :: BS.L.ByteString -> Signature -> Bool+verifySignature inp Signature{signature = sig, signatureKey = Some pub} =+  verify pub inp sig++instance (Monad m, ToJSON m a) => ToJSON m (Signed a) where+  toJSON Signed{..} = mkObject [+         ("signed"     , toJSON signed)+       , ("signatures" , toJSON signatures)+       ]++instance Monad m => ToJSON m Signatures where+  toJSON = toJSON . toPreSignatures++instance MonadKeys m => FromJSON m Signatures where+  fromJSON = fromPreSignatures <=< fromJSON++{-------------------------------------------------------------------------------+  JSON aids+-------------------------------------------------------------------------------}++-- | General FromJSON instance for signed datatypes+--+-- We don't give a general FromJSON instance for Signed because for some+-- datatypes we need to do something special (datatypes where we need to+-- read key environments); for instance, see the "Signed Root" instance.+signedFromJSON :: (MonadKeys m, FromJSON m a) => JSValue -> m (Signed a)+signedFromJSON envelope = do+    enc        <- fromJSField envelope "signed"+    signed     <- fromJSON enc+    signatures <- fromJSField envelope "signatures"+    validate "signatures" $ verifySignatures enc signatures+    return Signed{..}++-- | Signature verification+--+-- NOTES:+-- 1. By definition, the signature must be verified against the canonical+--    JSON format. This means we _must_ parse and then pretty print (as+--    we do here) because the document as stored may or may not be in+--    canonical format.+-- 2. However, it is important that we NOT translate from the JSValue+--    to whatever internal datatype we are using and then back to JSValue,+--    because that may not roundtrip: we must allow for additional fields+--    in the JSValue that we ignore (and would therefore lose when we+--    attempt to roundtrip).+-- 3. We verify that all signatures are valid, but we cannot verify (here)+--    that these signatures are signed with the right key, or that we+--    have a sufficient number of signatures. This will be the+--    responsibility of the calling code.+verifySignatures :: JSValue -> Signatures -> Bool+verifySignatures parsed (Signatures sigs) =+    all (verifySignature $ renderCanonicalJSON parsed) sigs++{-------------------------------------------------------------------------------+  Uninterpreted signatures+-------------------------------------------------------------------------------}++-- | File with uninterpreted signatures+--+-- Sometimes we want to be able to read a file without interpreting the+-- signatures (that is, resolving the key IDs) or doing any kind of checks on+-- them. One advantage of this is that this allows us to read many file types+-- without any key environment at all, which is sometimes useful.+data UninterpretedSignatures a = UninterpretedSignatures {+    uninterpretedSigned     :: a+  , uninterpretedSignatures :: [PreSignature]+  }+  deriving (Show)++-- | A signature with a key ID (rather than an actual key)+--+-- This corresponds precisely to the TUF representation of a signature.+data PreSignature = PreSignature {+    presignature :: BS.ByteString+  , presigMethod :: Some KeyType+  , presigKeyId  :: KeyId+  }+  deriving (Show)++-- | Convert a pre-signature to a signature+--+-- Verifies that the key type matches the advertised method.+fromPreSignature :: MonadKeys m => PreSignature -> m Signature+fromPreSignature PreSignature{..} = do+    key <- lookupKey presigKeyId+    validate "key type" $ typecheckSome key presigMethod+    return Signature {+        signature    = presignature+      , signatureKey = key+      }++-- | Convert signature to pre-signature+toPreSignature :: Signature -> PreSignature+toPreSignature Signature{..} = PreSignature {+      presignature = signature+    , presigMethod = somePublicKeyType signatureKey+    , presigKeyId  = someKeyId         signatureKey+    }++-- | Convert a list of 'PreSignature's to a list of 'Signature's+--+-- This verifies the invariant that all signatures are made with different keys.+-- We do this on the presignatures rather than the signatures so that we can do+-- the check on key IDs, rather than keys (the latter don't have an Ord+-- instance).+fromPreSignatures :: MonadKeys m => [PreSignature] -> m Signatures+fromPreSignatures sigs = do+      validate "all signatures made with different keys" $+        Set.size (Set.fromList (map presigKeyId sigs)) == length sigs+      Signatures <$> mapM fromPreSignature sigs++-- | Convert list of pre-signatures to a list of signatures+toPreSignatures :: Signatures -> [PreSignature]+toPreSignatures (Signatures sigs) = map toPreSignature sigs++instance ReportSchemaErrors m => FromJSON m PreSignature where+  fromJSON enc = do+    kId    <- fromJSField enc "keyid"+    method <- fromJSField enc "method"+    sig    <- fromJSField enc "sig"+    return PreSignature {+        presignature = B64.toByteString sig+      , presigMethod = method+      , presigKeyId  = KeyId kId+      }++instance Monad m => ToJSON m PreSignature where+  toJSON PreSignature{..} = mkObject [+         ("keyid"  , return $ JSString . keyIdString $ presigKeyId)+       , ("method" , toJSON $ presigMethod)+       , ("sig"    , toJSON $ B64.fromByteString presignature)+       ]++instance ( ReportSchemaErrors m+         , FromJSON m a+         ) => FromJSON m (UninterpretedSignatures a) where+  fromJSON envelope = do+    enc <- fromJSField envelope "signed"+    uninterpretedSigned     <- fromJSON enc+    uninterpretedSignatures <- fromJSField envelope "signatures"+    return UninterpretedSignatures{..}++instance (Monad m, ToJSON m a) => ToJSON m (UninterpretedSignatures a) where+  toJSON UninterpretedSignatures{..} = mkObject [+         ("signed"     , toJSON uninterpretedSigned)+       , ("signatures" , toJSON uninterpretedSignatures)+       ]
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE UndecidableInstances #-}+module Hackage.Security.TUF.Snapshot (+    Snapshot(..)+  ) where++import Control.Monad.Except+import Control.Monad.Reader++import Hackage.Security.JSON+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.FileInfo+import Hackage.Security.TUF.FileMap+import Hackage.Security.TUF.Layout.Repo+import Hackage.Security.TUF.Signed+import qualified Hackage.Security.TUF.FileMap as FileMap++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++data Snapshot = Snapshot {+    snapshotVersion :: FileVersion+  , snapshotExpires :: FileExpires++    -- | File info for the root metadata+    --+    -- We list this explicitly in the snapshot so that we can check if we need+    -- to update the root metadata without first having to download the entire+    -- index tarball.+  , snapshotInfoRoot :: FileInfo++    -- | File info for the mirror metadata+  , snapshotInfoMirrors :: FileInfo++    -- | Compressed index tarball+  , snapshotInfoTarGz :: FileInfo++    -- | Uncompressed index tarball+    --+    -- Repositories are not required to provide this.+  , snapshotInfoTar :: Maybe FileInfo+  }++instance HasHeader Snapshot where+  fileVersion f x = (\y -> x { snapshotVersion = y }) <$> f (snapshotVersion x)+  fileExpires f x = (\y -> x { snapshotExpires = y }) <$> f (snapshotExpires x)++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance MonadReader RepoLayout m => ToJSON m Snapshot where+  toJSON Snapshot{..} = do+      repoLayout <- ask+      mkObject [+          ("_type"   , return $ JSString "Snapshot")+        , ("version" , toJSON snapshotVersion)+        , ("expires" , toJSON snapshotExpires)+        , ("meta"    , toJSON (snapshotMeta repoLayout))+        ]+    where+      snapshotMeta repoLayout = FileMap.fromList $ [+          (pathRoot       repoLayout , snapshotInfoRoot)+        , (pathMirrors    repoLayout , snapshotInfoMirrors)+        , (pathIndexTarGz repoLayout , snapshotInfoTarGz)+        ] +++        [ (pathIndexTar   repoLayout , infoTar) | Just infoTar <- [snapshotInfoTar] ]++instance ( MonadReader RepoLayout m+         , MonadError DeserializationError m+         , ReportSchemaErrors m+         ) => FromJSON m Snapshot where+  fromJSON enc = do+    verifyType enc "Snapshot"+    repoLayout          <- ask+    snapshotVersion     <- fromJSField enc "version"+    snapshotExpires     <- fromJSField enc "expires"+    snapshotMeta        <- fromJSField enc "meta"+    snapshotInfoRoot    <- FileMap.lookupM snapshotMeta (pathRoot       repoLayout)+    snapshotInfoMirrors <- FileMap.lookupM snapshotMeta (pathMirrors    repoLayout)+    snapshotInfoTarGz   <- FileMap.lookupM snapshotMeta (pathIndexTarGz repoLayout)+    let snapshotInfoTar = FileMap.lookup (pathIndexTar repoLayout) snapshotMeta+    return Snapshot{..}++instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Snapshot) where+  fromJSON = signedFromJSON++{-------------------------------------------------------------------------------+  Paths used in the snapshot++  NOTE: Since the snapshot lives in the top-level directory of the repository,+  we can safely reinterpret "relative to the repo root" as "relative to the+  snapshot"; hence, this use of 'castRoot' is okay.+-------------------------------------------------------------------------------}++pathRoot, pathMirrors, pathIndexTarGz, pathIndexTar :: RepoLayout -> TargetPath+pathRoot       = TargetPathRepo . repoLayoutRoot+pathMirrors    = TargetPathRepo . repoLayoutMirrors+pathIndexTarGz = TargetPathRepo . repoLayoutIndexTarGz+pathIndexTar   = TargetPathRepo . repoLayoutIndexTar
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Targets.hs view
@@ -0,0 +1,130 @@+module Hackage.Security.TUF.Targets (+    -- * TUF types+    Targets(..)+  , Delegations(..)+  , DelegationSpec(..)+  , Delegation(..)+    -- ** Util+  , targetsLookup+  ) where++import Hackage.Security.JSON+import Hackage.Security.Key+import Hackage.Security.Key.Env (KeyEnv)+import Hackage.Security.TUF.Common+import Hackage.Security.TUF.FileInfo+import Hackage.Security.TUF.FileMap (FileMap, TargetPath)+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.Patterns+import Hackage.Security.TUF.Signed+import Hackage.Security.Util.Some+import qualified Hackage.Security.TUF.FileMap as FileMap++{-------------------------------------------------------------------------------+  TUF types+-------------------------------------------------------------------------------}++-- | Target metadata+--+-- Most target files do not need expiry dates because they are not subject to+-- change (and hence attacks like freeze attacks are not a concern).+data Targets = Targets {+    targetsVersion     :: FileVersion+  , targetsExpires     :: FileExpires+  , targetsTargets     :: FileMap+  , targetsDelegations :: Maybe Delegations+  }+  deriving (Show)++-- | Delegations+--+-- Much like the Root datatype, this must have an invariant that ALL used keys+-- (apart from the global keys, which are in the root key environment) must+-- be listed in 'delegationsKeys'.+data Delegations = Delegations {+    delegationsKeys  :: KeyEnv+  , delegationsRoles :: [DelegationSpec]+  }+  deriving (Show)++-- | Delegation specification+--+-- NOTE: This is a close analogue of 'RoleSpec'.+data DelegationSpec = DelegationSpec {+    delegationSpecKeys      :: [Some PublicKey]+  , delegationSpecThreshold :: KeyThreshold+  , delegation              :: Delegation+  }+  deriving (Show)++instance HasHeader Targets where+  fileVersion f x = (\y -> x { targetsVersion = y }) <$> f (targetsVersion x)+  fileExpires f x = (\y -> x { targetsExpires = y }) <$> f (targetsExpires x)++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++targetsLookup :: TargetPath -> Targets -> Maybe FileInfo+targetsLookup fp Targets{..} = FileMap.lookup fp targetsTargets++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m DelegationSpec where+  toJSON DelegationSpec{delegation = Delegation fp name, ..} = mkObject [+        ("name"      , toJSON name)+      , ("keyids"    , return . JSArray . map writeKeyAsId $ delegationSpecKeys)+      , ("threshold" , toJSON delegationSpecThreshold)+      , ("path"      , toJSON fp)+      ]++instance MonadKeys m => FromJSON m DelegationSpec where+  fromJSON enc = do+    delegationName          <- fromJSField enc "name"+    delegationSpecKeys      <- mapM readKeyAsId =<< fromJSField enc "keyids"+    delegationSpecThreshold <- fromJSField enc "threshold"+    delegationPath          <- fromJSField enc "path"+    case parseDelegation delegationName delegationPath of+      Left  err        -> expected ("valid name/path combination: " ++ err) Nothing+      Right delegation -> return DelegationSpec{..}++-- NOTE: Unlike the Root object, the keys that are used to sign the delegations+-- are NOT listed inside the delegations, so the same "bootstrapping" problems+-- do not arise here.+instance Monad m => ToJSON m Delegations where+  toJSON Delegations{..} = mkObject [+        ("keys"  , toJSON delegationsKeys)+      , ("roles" , toJSON delegationsRoles)+      ]++instance MonadKeys m => FromJSON m Delegations where+  fromJSON enc = do+    delegationsKeys  <- fromJSField enc "keys"+    delegationsRoles <- fromJSField enc "roles"+    return Delegations{..}++instance Monad m => ToJSON m Targets where+  toJSON Targets{..} = mkObject $ mconcat [+      [ ("_type"       , return $ JSString "Targets")+      , ("version"     , toJSON targetsVersion)+      , ("expires"     , toJSON targetsExpires)+      , ("targets"     , toJSON targetsTargets)+      ]+    , [ ("delegations" , toJSON d) | Just d <- [ targetsDelegations ] ]+    ]++instance MonadKeys m => FromJSON m Targets where+  fromJSON enc = do+    verifyType enc "Targets"+    targetsVersion     <- fromJSField    enc "version"+    targetsExpires     <- fromJSField    enc "expires"+    targetsTargets     <- fromJSField    enc "targets"+    targetsDelegations <- fromJSOptField enc "delegations"+    return Targets{..}++-- TODO: This is okay right now because targets do not introduce additional+-- keys, but will no longer be okay once we have author keys.+instance MonadKeys m => FromJSON m (Signed Targets) where+  fromJSON = signedFromJSON
+ hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE UndecidableInstances #-}+module Hackage.Security.TUF.Timestamp (+    Timestamp(..)+  ) where++import Control.Monad.Except+import Control.Monad.Reader++import Hackage.Security.JSON+import Hackage.Security.TUF.FileInfo+import Hackage.Security.TUF.FileMap+import Hackage.Security.TUF.Header+import Hackage.Security.TUF.Layout.Repo+import Hackage.Security.TUF.Signed+import qualified Hackage.Security.TUF.FileMap as FileMap++{-------------------------------------------------------------------------------+  Datatypes+-------------------------------------------------------------------------------}++data Timestamp = Timestamp {+    timestampVersion      :: FileVersion+  , timestampExpires      :: FileExpires+  , timestampInfoSnapshot :: FileInfo+  }++instance HasHeader Timestamp where+  fileVersion f x = (\y -> x { timestampVersion = y }) <$> f (timestampVersion x)+  fileExpires f x = (\y -> x { timestampExpires = y }) <$> f (timestampExpires x)++{-------------------------------------------------------------------------------+  JSON+-------------------------------------------------------------------------------}++instance MonadReader RepoLayout m => ToJSON m Timestamp where+  toJSON Timestamp{..} = do+      repoLayout <- ask+      mkObject [+          ("_type"   , return $ JSString "Timestamp")+        , ("version" , toJSON timestampVersion)+        , ("expires" , toJSON timestampExpires)+        , ("meta"    , toJSON (timestampMeta repoLayout))+        ]+    where+      timestampMeta repoLayout = FileMap.fromList [+          (pathSnapshot repoLayout, timestampInfoSnapshot)+        ]++instance ( MonadReader RepoLayout m+         , MonadError DeserializationError m+         , ReportSchemaErrors m+         ) => FromJSON m Timestamp where+  fromJSON enc = do+    verifyType enc "Timestamp"+    repoLayout            <- ask+    timestampVersion      <- fromJSField enc "version"+    timestampExpires      <- fromJSField enc "expires"+    timestampMeta         <- fromJSField enc "meta"+    timestampInfoSnapshot <- FileMap.lookupM timestampMeta (pathSnapshot repoLayout)+    return Timestamp{..}++instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where+  fromJSON = signedFromJSON++{-------------------------------------------------------------------------------+  Paths used in the timestamp++  NOTE: Since the timestamp lives in the top-level directory of the repository,+  we can safely reinterpret "relative to the repo root" as "relative to the+  timestamp"; hence, this use of 'castRoot' is okay.+-------------------------------------------------------------------------------}++pathSnapshot :: RepoLayout -> TargetPath+pathSnapshot = TargetPathRepo . repoLayoutSnapshot
+ hackage-security/hackage-security/src/Hackage/Security/Trusted.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE StaticPointers #-}+#endif+module Hackage.Security.Trusted (+    module Hackage.Security.Trusted.TCB+    -- * Derived functions+  , (<$$>)+    -- ** Role verification+  , VerifyRole(..)+    -- ** File info verification+  , trustedFileInfoEqual+  ) where++import Data.Function (on)+import Data.Time+import Hackage.Security.TUF+import Hackage.Security.Trusted.TCB hiding (DeclareTrusted)++{-------------------------------------------------------------------------------+  Combinators on trusted values+-------------------------------------------------------------------------------}++-- | Apply a static function to a trusted argument+(<$$>) :: StaticPtr (a -> b) -> Trusted a -> Trusted b+(<$$>) = trustApply . trustStatic++{-------------------------------------------------------------------------------+  Role verification+-------------------------------------------------------------------------------}++class VerifyRole a where+  verifyRole :: Trusted Root      -- ^ Root data+             -> TargetPath        -- ^ Source (for error messages)+             -> Maybe FileVersion -- ^ Previous version (if available)+             -> Maybe UTCTime     -- ^ Time now (if checking expiry)+             -> Signed a          -- ^ Mirrors to verify+             -> Either VerificationError (SignaturesVerified a)++instance VerifyRole Root where+  verifyRole = verifyRole' . (static (rootRolesRoot . rootRoles) <$$>)++instance VerifyRole Timestamp where+  verifyRole = verifyRole' . (static (rootRolesTimestamp . rootRoles) <$$>)++instance VerifyRole Snapshot where+  verifyRole = verifyRole' . (static (rootRolesSnapshot . rootRoles) <$$>)++instance VerifyRole Mirrors where+  verifyRole = verifyRole' . (static (rootRolesMirrors . rootRoles) <$$>)++{-------------------------------------------------------------------------------+  File info verification+-------------------------------------------------------------------------------}++-- | Variation on 'knownFileInfoEqual' for 'Trusted' 'FileInfo'+trustedFileInfoEqual :: Trusted FileInfo -> Trusted FileInfo -> Bool+trustedFileInfoEqual = knownFileInfoEqual `on` trusted
+ hackage-security/hackage-security/src/Hackage/Security/Trusted/TCB.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE CPP #-}+module Hackage.Security.Trusted.TCB (+    -- * Trusted values+    Trusted(DeclareTrusted)+  , trusted+  , trustStatic+  , trustVerified+  , trustApply+  , trustElems+    -- * Verification errors+  , VerificationError(..)+  , RootUpdated(..)+  , VerificationHistory+    -- * Role verification+  , SignaturesVerified -- opaque+  , signaturesVerified+  , verifyRole'+  , verifyFingerprints+#if __GLASGOW_HASKELL__ >= 710+    -- * Re-exports+  , StaticPtr+#else+    -- * Fake static pointers+  , StaticPtr+  , static+#endif+  ) where++import Control.Exception+import Control.Monad.Except+import Data.Typeable+import Data.Time+import Hackage.Security.TUF+import Hackage.Security.JSON+import Hackage.Security.Key+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Util.Lens as Lens++#if __GLASGOW_HASKELL__ >= 710+import GHC.StaticPtr+#else+-- Fake static pointers for ghc < 7.10. This means Trusted offers no+-- additional type safety, but that's okay: we can still verify the code+-- with ghc 7.10 and get the additional checks.+newtype StaticPtr a = StaticPtr { deRefStaticPtr :: a }++static :: a -> StaticPtr a+static = StaticPtr+#endif++-- | Trusted values+--+-- Trusted values originate in only two ways:+--+-- * Anything that is statically known is trusted ('trustStatic')+-- * If we have "dynamic" data we can trust it once we have verified the+--   the signatures (trustSigned).+--+-- NOTE: Trusted is NOT a functor. If it was we could define+--+-- > trustAnything :: a -> Trusted a+-- > trustAnything a = fmap (const a) (trustStatic (static ()))+--+-- Consequently, it is neither a monad nor a comonad. However, we _can_ apply+-- trusted functions to trusted arguments ('trustApply').+--+-- The 'DeclareTrusted' constructor is exported, but any use of it should be+-- verified.+newtype Trusted a = DeclareTrusted { trusted :: a }+  deriving (Eq, Show)++trustStatic :: StaticPtr a -> Trusted a+trustStatic = DeclareTrusted . deRefStaticPtr++trustVerified :: SignaturesVerified a -> Trusted a+trustVerified = DeclareTrusted . signaturesVerified++-- | Equivalent of '<*>'+--+-- Trusted isn't quite applicative (no pure, not a functor), but it is+-- somehow Applicative-like: we have the equivalent of '<*>'+trustApply :: Trusted (a -> b) -> Trusted a -> Trusted b+trustApply (DeclareTrusted f) (DeclareTrusted x) = DeclareTrusted (f x)++-- | Trust all elements of some trusted (traversable) container+--+-- If we have, say, a trusted list of values, we should be able to get a list+-- of trusted values out of it.+--+-- > trustElems :: Trusted [a] -> [Trusted a]+--+-- NOTE. It might appear that the more natural primitive to offer is a+-- 'sequenceA'-like operator such as+--+-- > trustSeq :: Applicative f => Trusted (f a) -> f (Trusted a)+--+-- However, this is unsound. To see this, consider that @((->) a)@ is+-- 'Applicative' (it's the reader monad); hence, we can instantiate 'trustSeq'+-- at+--+-- > trustSeq :: Trusted (a -> a) -> a -> Trusted a+--+-- and by passing @trustStatic (static id)@ make 'Trusted' a functor, which we+-- certainly don't want to do (see comments for 'Trusted').+--+-- So why is it okay when we insist on 'Traversable' rather than 'Applicative'?+-- To see this, it's instructive to consider how we might make a @((->) a)@ an+-- instance of 'Traversable'. If we define the domain of enumerable types as+--+-- > class Eq a => Enumerable a where+-- >   enumerate :: [a]+--+-- then we can make @((->) r)@ traversable by+--+-- > instance Enumerable r => Traversable ((->) r) where+-- >   sequenceA f = rebuild <$> sequenceA ((\r -> (r,) <$> f r) <$> enumerate)+-- >     where+-- >       rebuild :: [(r, a)] -> r -> a+-- >       rebuild fun arg = fromJust (lookup arg fun)+--+-- The idea is that if the domain of a function is enumerable, we can apply the+-- function to each possible input, collect the outputs, and construct a new+-- function by pairing the inputs with the outputs. I.e., if we had something of+-- type+--+-- > a -> IO b+--+-- and @a@ is enumerable, we just run the @IO@ action on each possible @a@ and+-- collect all @b@s to get a pure function @a -> b@. Of course, you probably+-- don't want to be doing that, but the point is that as far as the type system+-- is concerned you could.+--+-- In the context of 'Trusted', this means that we can derive+--+-- > enumPure :: Enumerable a => a -> Trusted a+--+-- but in a way this this makes sense anyway. If a domain is enumerable, it+-- would not be unreasonable to change @Enumerable@ to+--+-- > class Eq a => Enumerable a where+-- >   enumerate :: [StaticPtr a]+--+-- so we could define @enumPure@ as+--+-- > enumPure :: Enumerable a => a -> Trusted a+-- > enumPure x = trustStatic+-- >            $ fromJust (find ((== x) . deRefStaticPtr) enumerate)+--+-- In other words, we just enumerate the entire domain as trusted values+-- (because we defined them locally) and then return the one that matched the+-- untrusted value.+--+-- The conclusion from all of this is that the types of untrusted input  (like+-- the types of the TUF files we download from the server) should probably not+-- be considered enumerable.+trustElems :: Traversable f => Trusted (f a) -> f (Trusted a)+trustElems (DeclareTrusted fa) = DeclareTrusted `fmap` fa++{-------------------------------------------------------------------------------+  Role verification+-------------------------------------------------------------------------------}++newtype SignaturesVerified a = SignaturesVerified { signaturesVerified :: a }++-- | Errors thrown during role validation+data VerificationError =+     -- | Not enough signatures signed with the appropriate keys+     VerificationErrorSignatures TargetPath++     -- | The file is expired+   | VerificationErrorExpired TargetPath++     -- | The file version is less than the previous version+   | VerificationErrorVersion TargetPath++     -- | File information mismatch+   | VerificationErrorFileInfo TargetPath++     -- | We tried to lookup file information about a particular target file,+     -- but the information wasn't in the corresponding @targets.json@ file.+   | VerificationErrorUnknownTarget TargetPath++     -- | The metadata for the specified target is missing a SHA256+   | VerificationErrorMissingSHA256 TargetPath++     -- | Some verification errors materialize as deserialization errors+     --+     -- For example: if we try to deserialize a timestamp file but the timestamp+     -- key has been rolled over, deserialization of the file will fail with+     -- 'DeserializationErrorUnknownKey'.+   | VerificationErrorDeserialization TargetPath DeserializationError++     -- | The spec stipulates that if a verification error occurs during+     -- the check for updates, we must download new root information and+     -- start over. However, we limit how often we attempt this.+     --+     -- We record all verification errors that occurred before we gave up.+   | VerificationErrorLoop VerificationHistory+   deriving (Typeable)++-- | Root metadata updated (as part of the normal update process)+data RootUpdated = RootUpdated+  deriving (Typeable)++type VerificationHistory = [Either RootUpdated VerificationError]++#if MIN_VERSION_base(4,8,0)+deriving instance Show VerificationError+deriving instance Show RootUpdated+instance Exception VerificationError where displayException = pretty+instance Exception RootUpdated where displayException = pretty+#else+instance Exception VerificationError+instance Show VerificationError where show = pretty+instance Show RootUpdated where show = pretty+instance Exception RootUpdated+#endif++instance Pretty VerificationError where+  pretty (VerificationErrorSignatures file) =+      pretty file ++ " does not have enough signatures signed with the appropriate keys"+  pretty (VerificationErrorExpired file) =+      pretty file ++ " is expired"+  pretty (VerificationErrorVersion file) =+      "Version of " ++ pretty file ++ " is less than the previous version"+  pretty (VerificationErrorFileInfo file) =+      "Invalid hash for " ++ pretty file+  pretty (VerificationErrorUnknownTarget file) =+      pretty file ++ " not found in corresponding target metadata"+  pretty (VerificationErrorMissingSHA256 file) =+      "Missing SHA256 hash for " ++ pretty file+  pretty (VerificationErrorDeserialization file err) =+      "Could not deserialize " ++ pretty file ++ ": " ++ pretty err+  pretty (VerificationErrorLoop es) =+      "Verification loop. Errors in order:\n"+   ++ unlines (map (("  " ++) . either pretty pretty) es)++instance Pretty RootUpdated where+  pretty RootUpdated = "Root information updated"++-- | Role verification+--+-- NOTE: We throw an error when the version number _decreases_, but allow it+-- to be the same. This is sufficient: the file number is there so that+-- attackers cannot replay old files. It cannot protect against freeze attacks+-- (that's what the expiry date is for), so "replaying" the same file is not+-- a problem. If an attacker changes the contents of the file but not the+-- version number we have an inconsistent situation, but this is not something+-- we need to worry about: in this case the attacker will need to resign the+-- file or otherwise the signature won't match, and if the attacker has+-- compromised the key then he might just as well increase the version number+-- and resign.+--+-- NOTE 2: We are not actually verifying the signatures _themselves_ here+-- (we did that when we parsed the JSON). We are merely verifying the provenance+-- of the keys.+verifyRole' :: forall a. HasHeader a+            => Trusted (RoleSpec a)     -- ^ For signature validation+            -> TargetPath               -- ^ File source (for error messages)+            -> Maybe FileVersion        -- ^ Previous version (if available)+            -> Maybe UTCTime            -- ^ Time now (if checking expiry)+            -> Signed a -> Either VerificationError (SignaturesVerified a)+verifyRole' (trusted -> RoleSpec{roleSpecThreshold = KeyThreshold threshold, ..})+            targetPath+            mPrev+            mNow+            Signed{signatures = Signatures sigs, ..} =+    runExcept go+  where+    go :: Except VerificationError (SignaturesVerified a)+    go = do+      -- Verify expiry date+      case mNow of+        Just now ->+          when (isExpired now (Lens.get fileExpires signed)) $+            throwError $ VerificationErrorExpired targetPath+        _otherwise ->+          return ()++      -- Verify timestamp+      case mPrev of+        Nothing   -> return ()+        Just prev ->+          when (Lens.get fileVersion signed < prev) $+            throwError $ VerificationErrorVersion targetPath++      -- Verify signatures+      -- NOTE: We only need to verify the keys that were used; if the signature+      -- was invalid we would already have thrown an error constructing Signed.+      -- (Similarly, if two signatures were made by the same key, the FromJSON+      -- instance for Signatures would have thrown an error.)+      unless (length (filter isRoleSpecKey sigs) >= fromIntegral threshold) $+        throwError $ VerificationErrorSignatures targetPath++      -- Everything is A-OK!+      return $ SignaturesVerified signed++    isRoleSpecKey :: Signature -> Bool+    isRoleSpecKey Signature{..} = signatureKey `elem` roleSpecKeys++-- | Variation on 'verifyRole' that uses key IDs rather than keys+--+-- This is used during the bootstrap process.+--+-- See <http://en.wikipedia.org/wiki/Public_key_fingerprint>.+verifyFingerprints :: [KeyId]+                   -> KeyThreshold+                   -> TargetPath      -- ^ For error messages+                   -> Signed Root+                   -> Either VerificationError (SignaturesVerified Root)+verifyFingerprints fingerprints+                   (KeyThreshold threshold)+                   targetPath+                   Signed{signatures = Signatures sigs, ..} =+    if length (filter isTrustedKey sigs) >= fromIntegral threshold+      then Right $ SignaturesVerified signed+      else Left $ VerificationErrorSignatures targetPath+  where+    isTrustedKey :: Signature -> Bool+    isTrustedKey Signature{..} = someKeyId signatureKey `elem` fingerprints
+ hackage-security/hackage-security/src/Hackage/Security/Util/Base64.hs view
@@ -0,0 +1,31 @@+module Hackage.Security.Util.Base64 (+    Base64 -- opaque+  , fromByteString+  , toByteString+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8  as C8  -- only called on B64-enc strings+import qualified Data.ByteString.Base64 as B64++import Hackage.Security.Util.JSON++-- | Simple wrapper around bytestring with ToJSON and FromJSON instances that+-- use base64 encoding.+newtype Base64 = Base64 ByteString++fromByteString :: ByteString -> Base64+fromByteString = Base64++toByteString :: Base64 -> ByteString+toByteString (Base64 bs) = bs++instance Monad m => ToJSON m Base64 where+  toJSON (Base64 bs) = toJSON (C8.unpack (B64.encode bs))++instance ReportSchemaErrors m => FromJSON m Base64 where+  fromJSON val = do+    str <- fromJSON val+    case B64.decode (C8.pack str) of+      Left _err -> expected "base-64 encoded string" Nothing+      Right bs  -> return $ Base64 bs
+ hackage-security/hackage-security/src/Hackage/Security/Util/Checked.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations     #-}+{-# LANGUAGE IncoherentInstances #-}+#endif++-- | Checked exceptions+module Hackage.Security.Util.Checked (+    Throws+  , unthrow+    -- ** Base exceptions+  , throwChecked+  , catchChecked+  , handleChecked+  , tryChecked+  , checkIO+  , throwUnchecked+  , internalError+  ) where++import Control.Exception (Exception, IOException)+import qualified Control.Exception as Base++#if __GLASGOW_HASKELL__ >= 708+import GHC.Prim (coerce)+#else+import Unsafe.Coerce (unsafeCoerce)+#endif++{-------------------------------------------------------------------------------+  Basic infrastructure+-------------------------------------------------------------------------------}++-- | Checked exceptions+class Throws e where++#if __GLASGOW_HASKELL__ >= 708+type role Throws representational+#endif++unthrow :: forall a e proxy . proxy e -> (Throws e => a) -> a+unthrow _ x = unWrap (coerceWrap (Wrap x :: Wrap e a))++{-------------------------------------------------------------------------------+  Base exceptions+-------------------------------------------------------------------------------}++-- | Throw a checked exception+throwChecked :: (Exception e, Throws e) => e -> IO a+throwChecked = Base.throwIO++-- | Catch a checked exception+catchChecked :: forall a e. Exception e+             => (Throws e => IO a) -> (e -> IO a) -> IO a+catchChecked act = Base.catch (unthrow (Proxy :: Proxy e) act)++-- | 'catchChecked' with the arguments reversed+handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a+handleChecked act handler = catchChecked handler act++-- | Like 'try', but for checked exceptions+tryChecked :: Exception e => (Throws e => IO a) -> IO (Either e a)+tryChecked act = catchChecked (Right <$> act) (return . Left)++-- | Rethrow IO exceptions as checked exceptions+checkIO :: Throws IOException => IO a -> IO a+checkIO = Base.handle $ \(ex :: IOException) -> throwChecked ex++-- | Throw an unchecked exception+--+-- This is just an alias for 'throw', but makes it evident that this is a very+-- intentional use of an unchecked exception.+throwUnchecked :: Exception e => e -> IO a+throwUnchecked = Base.throwIO++-- | Variation on 'throwUnchecked' for internal errors+internalError :: String -> IO a+internalError = throwUnchecked . userError++{-------------------------------------------------------------------------------+  Auxiliary definitions (not exported)+-------------------------------------------------------------------------------}++-- | Wrap an action that may throw a checked exception+--+-- This is used internally in 'unthrow' to avoid impredicative+-- instantiation of the type of 'coerce'/'unsafeCoerce'.+newtype Wrap e a = Wrap { unWrap :: Throws e => a }++coerceWrap :: Wrap e a -> Wrap (Catch e) a+#if __GLASGOW_HASKELL__ >= 708+coerceWrap = coerce+#else+coerceWrap = unsafeCoerce+#endif++data Proxy a = Proxy++newtype Catch a = Catch a+instance Throws (Catch e) where
+ hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs view
@@ -0,0 +1,61 @@+module Hackage.Security.Util.IO (+    -- * Miscelleneous+    getFileSize+  , handleDoesNotExist+  , withDirLock+    -- * Debugging+  , timedIO+  ) where++import Control.Exception+import Data.Time+import System.IO hiding (openTempFile, withFile)+import System.IO.Error++import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  Miscelleneous+-------------------------------------------------------------------------------}++getFileSize :: (Num a, FsRoot root) => Path root -> IO a+getFileSize fp = fromInteger <$> withFile fp ReadMode hFileSize++handleDoesNotExist :: IO a -> IO (Maybe a)+handleDoesNotExist act =+   handle aux (Just <$> act)+  where+    aux e =+      if isDoesNotExistError e+        then return Nothing+        else throwIO e++-- | Attempt to create a filesystem lock in the specified directory+--+-- Given a file @/path/to@, we do this by attempting to create the directory+-- @//path/to/hackage-security-lock@, and deleting the directory again+-- afterwards. Creating a directory that already exists will throw an exception+-- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way+-- to implement a lock file.+withDirLock :: Path Absolute -> IO a -> IO a+withDirLock dir = bracket_ takeLock releaseLock+  where+    lock :: Path Absolute+    lock = dir </> fragment "hackage-security-lock"++    takeLock, releaseLock :: IO ()+    takeLock    = createDirectory lock+    releaseLock = removeDirectory lock++{-------------------------------------------------------------------------------+  Debugging+-------------------------------------------------------------------------------}++timedIO :: String -> IO a -> IO a+timedIO label act = do+    before <- getCurrentTime+    result <- act+    after  <- getCurrentTime+    hPutStrLn stderr $ label ++ ": " ++ show (after `diffUTCTime` before)+    hFlush stderr+    return result
+ hackage-security/hackage-security/src/Hackage/Security/Util/JSON.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif+-- |+module Hackage.Security.Util.JSON (+    -- * Type classes+    ToJSON(..)+  , FromJSON(..)+  , ToObjectKey(..)+  , FromObjectKey(..)+  , ReportSchemaErrors(..)+  , Expected+  , Got+  , expected'+    -- * Utility+  , fromJSObject+  , fromJSField+  , fromJSOptField+  , mkObject+    -- * Re-exports+  , JSValue(..)+  , Int54+  ) where++import Control.Monad (liftM)+import Data.Map (Map)+import Data.Time+import Text.JSON.Canonical+import Network.URI+import qualified Data.Map as Map++#if !MIN_VERSION_time(1,5,0)+import System.Locale (defaultTimeLocale)+#endif++import Hackage.Security.Util.Path++{-------------------------------------------------------------------------------+  ToJSON and FromJSON classes++  We parameterize over the monad here to avoid mutual module dependencies.+-------------------------------------------------------------------------------}++class ToJSON m a where+  toJSON :: a -> m JSValue++class FromJSON m a where+  fromJSON :: JSValue -> m a++-- | Used in the 'ToJSON' instance for 'Map'+class ToObjectKey m a where+  toObjectKey :: a -> m String++-- | Used in the 'FromJSON' instance for 'Map'+class FromObjectKey m a where+  fromObjectKey :: String -> m a++-- | Monads in which we can report schema errors+class (Applicative m, Monad m) => ReportSchemaErrors m where+  expected :: Expected -> Maybe Got -> m a++type Expected = String+type Got      = String++expected' :: ReportSchemaErrors m => Expected -> JSValue -> m a+expected' descr val = expected descr (Just (describeValue val))+  where+    describeValue :: JSValue -> String+    describeValue (JSNull    ) = "null"+    describeValue (JSBool   _) = "bool"+    describeValue (JSNum    _) = "num"+    describeValue (JSString _) = "string"+    describeValue (JSArray  _) = "array"+    describeValue (JSObject _) = "object"++unknownField :: ReportSchemaErrors m => String -> m a+unknownField field = expected ("field " ++ show field) Nothing++{-------------------------------------------------------------------------------+  ToObjectKey and FromObjectKey instances+-------------------------------------------------------------------------------}++instance Monad m => ToObjectKey m String where+  toObjectKey = return++instance Monad m => FromObjectKey m String where+  fromObjectKey = return++instance Monad m => ToObjectKey m (Path root) where+  toObjectKey (Path fp) = return fp++instance Monad m => FromObjectKey m (Path root) where+  fromObjectKey = liftM Path . fromObjectKey++{-------------------------------------------------------------------------------+  ToJSON and FromJSON instances+-------------------------------------------------------------------------------}++instance Monad m => ToJSON m JSValue where+  toJSON = return++instance Monad m => FromJSON m JSValue where+  fromJSON = return++instance Monad m => ToJSON m String where+  toJSON = return . JSString++instance ReportSchemaErrors m => FromJSON m String where+  fromJSON (JSString str) = return str+  fromJSON val            = expected' "string" val++instance Monad m => ToJSON m Int54 where+  toJSON = return . JSNum++instance ReportSchemaErrors m => FromJSON m Int54 where+  fromJSON (JSNum i) = return i+  fromJSON val       = expected' "int" val++instance+#if __GLASGOW_HASKELL__ >= 710+  {-# OVERLAPPABLE #-}+#endif+    (Monad m, ToJSON m a) => ToJSON m [a] where+  toJSON = liftM JSArray . mapM toJSON++instance+#if __GLASGOW_HASKELL__ >= 710+  {-# OVERLAPPABLE #-}+#endif+    (ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where+  fromJSON (JSArray as) = mapM fromJSON as+  fromJSON val          = expected' "array" val++instance Monad m => ToJSON m UTCTime where+  toJSON = return . JSString . formatTime defaultTimeLocale "%FT%TZ"++instance ReportSchemaErrors m => FromJSON m UTCTime where+  fromJSON enc = do+    str <- fromJSON enc+    case parseTimeM False defaultTimeLocale "%FT%TZ" str of+      Just time -> return time+      Nothing   -> expected "valid date-time string" (Just str)+#if !MIN_VERSION_time(1,5,0)+    where+      parseTimeM _trim = parseTime+#endif++instance ( Monad m+         , ToObjectKey m k+         , ToJSON m a+         ) => ToJSON m (Map k a) where+  toJSON = liftM JSObject . mapM aux . Map.toList+    where+      aux :: (k, a) -> m (String, JSValue)+      aux (k, a) = do k' <- toObjectKey k; a' <- toJSON a; return (k', a')++instance ( ReportSchemaErrors m+         , Ord k+         , FromObjectKey m k+         , FromJSON m a+         ) => FromJSON m (Map k a) where+  fromJSON enc = do+      obj <- fromJSObject enc+      Map.fromList <$> mapM aux obj+    where+      aux :: (String, JSValue) -> m (k, a)+      aux (k, a) = (,) <$> fromObjectKey k <*> fromJSON a++instance Monad m => ToJSON m URI where+  toJSON = toJSON . show++instance ReportSchemaErrors m => FromJSON m URI where+  fromJSON enc = do+    str <- fromJSON enc+    case parseURI str of+      Nothing  -> expected "valid URI" (Just str)+      Just uri -> return uri++{-------------------------------------------------------------------------------+  Utility+-------------------------------------------------------------------------------}++fromJSObject :: ReportSchemaErrors m => JSValue -> m [(String, JSValue)]+fromJSObject (JSObject obj) = return obj+fromJSObject val            = expected' "object" val++-- | Extract a field from a JSON object+fromJSField :: (ReportSchemaErrors m, FromJSON m a)+            => JSValue -> String -> m a+fromJSField val nm = do+    obj <- fromJSObject val+    case lookup nm obj of+      Just fld -> fromJSON fld+      Nothing  -> unknownField nm++fromJSOptField :: (ReportSchemaErrors m, FromJSON m a)+               => JSValue -> String -> m (Maybe a)+fromJSOptField val nm = do+    obj <- fromJSObject val+    case lookup nm obj of+      Just fld -> Just <$> fromJSON fld+      Nothing  -> return Nothing++mkObject :: forall m. Monad m => [(String, m JSValue)] -> m JSValue+mkObject = liftM JSObject . sequenceFields+  where+    sequenceFields :: [(String, m JSValue)] -> m [(String, JSValue)]+    sequenceFields []               = return []+    sequenceFields ((fld,val):flds) = do val' <- val+                                         flds' <- sequenceFields flds+                                         return ((fld,val'):flds')
+ hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs view
@@ -0,0 +1,48 @@+-- | Some very simple lens definitions (to avoid further dependencies)+--+-- Intended to be double-imported+-- > import Hackage.Security.Util.Lens (Lens)+-- > import qualified Hackage.Security.Util.Lens as Lens+module Hackage.Security.Util.Lens (+    -- * Generic definitions+    Lens+  , Lens'+  , get+  , modify+  , set+    -- * Specific lenses+  , lookupM+  ) where++import Control.Applicative+import Data.Functor.Identity++{-------------------------------------------------------------------------------+  General definitions+-------------------------------------------------------------------------------}++-- | Polymorphic lens+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++-- | Monomorphic lens+type Lens' s a = Lens s s a a++get :: Lens' s a -> s -> a+get l = getConst . l Const++modify :: Lens s t a b -> (a -> b) -> s -> t+modify l f = runIdentity . l (Identity . f)++set :: Lens s t a b -> b -> s -> t+set l = modify l . const++{-------------------------------------------------------------------------------+  Specific lenses+-------------------------------------------------------------------------------}++lookupM :: forall a b. (Eq a, Monoid b) => a -> Lens' [(a, b)] b+lookupM a f = go+  where+    go []                       = (\b'  -> [(a, b')]  ) <$> f mempty+    go ((a', b):xs) | a == a'   = (\b'  -> (a, b'):xs ) <$> f b+                    | otherwise = (\xs' -> (a', b):xs') <$> go xs
+ hackage-security/hackage-security/src/Hackage/Security/Util/Path.hs view
@@ -0,0 +1,459 @@+-- | A more type-safe version of file paths+--+-- This module is intended to replace imports of System.FilePath, and+-- additionally exports thin wrappers around common IO functions.  To facilitate+-- importing this module unqualified we also re-export some  definitions from+-- System.IO (importing both would likely lead to name clashes).+--+-- Note that his module does not import any other modules from Hackage.Security;+-- everywhere else we use Path instead of FilePath directly.+{-# LANGUAGE CPP #-}+module Hackage.Security.Util.Path (+    -- * Paths+    Path(..)+  , castRoot+    -- * FilePath-like operations on paths with arbitrary roots+  , takeDirectory+  , takeFileName+  , (<.>)+  , splitExtension+    -- * Unrooted paths+  , Unrooted+  , (</>)+  , rootPath+  , unrootPath+  , toUnrootedFilePath+  , fromUnrootedFilePath+  , fragment+  , joinFragments+  , isPathPrefixOf+    -- * File-system paths+  , Relative+  , Absolute+  , HomeDir+  , FsRoot(..)+  , FsPath(..)+    -- ** Conversions+  , toFilePath+  , fromFilePath+  , makeAbsolute+  , fromAbsoluteFilePath+    -- ** Wrappers around System.IO+  , withFile+  , openTempFile'+    -- ** Wrappers around Data.ByteString+  , readLazyByteString+  , readStrictByteString+  , writeLazyByteString+  , writeStrictByteString+    -- ** Wrappers around System.Directory+  , copyFile+  , createDirectory+  , createDirectoryIfMissing+  , removeDirectory+  , doesFileExist+  , doesDirectoryExist+  , removeFile+  , getTemporaryDirectory+  , getDirectoryContents+  , getRecursiveContents+  , renameFile+  , getCurrentDirectory+    -- * Wrappers around Codec.Archive.Tar+  , Tar+  , tarIndexLookup+  , tarAppend+    -- * Wrappers around Network.URI+  , Web+  , toURIPath+  , fromURIPath+  , uriPath+  , modifyUriPath+    -- * Re-exports+  , IOMode(..)+  , BufferMode(..)+  , Handle+  , SeekMode(..)+  , IO.hSetBuffering+  , IO.hClose+  , IO.hFileSize+  , IO.hSeek+  ) where++import Control.Monad+import Data.List (isPrefixOf)+import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..))+import System.IO.Unsafe (unsafeInterleaveIO)+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Lazy    as BS.L+import qualified System.FilePath         as FP+import qualified System.IO               as IO+import qualified System.Directory        as Dir+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Index as TarIndex+import qualified Network.URI             as URI++import Hackage.Security.Util.Pretty++{-------------------------------------------------------------------------------+  Paths+-------------------------------------------------------------------------------}++-- | Paths+--+-- A 'Path' is simply a 'FilePath' with a type-level tag indicating where this+-- path is rooted (relative to the current directory, absolute path, relative to+-- a web domain, whatever). Most operations on 'Path' are just lifted versions+-- of the operations on the underlying 'FilePath'. The tag however allows us to+-- give a lot of operations a more meaningful type. For instance, it does not+-- make sense to append two absolute paths together; instead, we can only append+-- an unrooted path to another path. It also means we avoid bugs where we use+-- one kind of path where we expect another.+newtype Path a = Path { unPath :: FilePath }+  deriving (Show, Eq, Ord)++-- | Reinterpret the root of a path+--+-- This literally just changes the type-level tag; use with caution!+castRoot :: Path root -> Path root'+castRoot (Path fp) = Path fp++{-------------------------------------------------------------------------------+  FilePath-like operations on paths with an arbitrary root+-------------------------------------------------------------------------------}++takeDirectory :: Path a -> Path a+takeDirectory = liftFP FP.takeDirectory++takeFileName :: Path a -> String+takeFileName = liftFromFP FP.takeFileName++(<.>) :: Path a -> String -> Path a+fp <.> ext = liftFP (FP.<.> ext) fp++splitExtension :: Path a -> (Path a, String)+splitExtension (Path fp) = (Path fp', ext)+  where+    (fp', ext) = FP.splitExtension fp++{-------------------------------------------------------------------------------+  Unrooted paths+-------------------------------------------------------------------------------}++-- | Type-level tag for unrooted paths+--+-- Unrooted paths need a root before they can be interpreted.+data Unrooted++instance Pretty (Path Unrooted) where+  pretty (Path fp) = fp++(</>) :: Path a -> Path Unrooted -> Path a+(</>) = liftFP2 (FP.</>)++-- | Reinterpret an unrooted path+--+-- This is an alias for 'castRoot'; see comments there.+rootPath :: Path Unrooted -> Path root+rootPath (Path fp) = Path fp++-- | Forget a path's root+--+-- This is an alias for 'castRoot'; see comments there.+unrootPath :: Path root -> Path Unrooted+unrootPath (Path fp) = Path fp++toUnrootedFilePath :: Path Unrooted -> FilePath+toUnrootedFilePath = unPath++fromUnrootedFilePath :: FilePath -> Path Unrooted+fromUnrootedFilePath = Path++-- | A path fragment (like a single directory or filename)+fragment :: String -> Path Unrooted+fragment = fromUnrootedFilePath++joinFragments :: [String] -> Path Unrooted+joinFragments = liftToFP FP.joinPath++isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool+isPathPrefixOf = liftFromFP2 isPrefixOf++{-------------------------------------------------------------------------------+  File-system paths+-------------------------------------------------------------------------------}++data Relative+data Absolute+data HomeDir++instance Pretty (Path Absolute) where+  pretty (Path fp) = fp++instance Pretty (Path Relative) where+  pretty (Path fp) = "./" ++ fp++instance Pretty (Path HomeDir) where+  pretty (Path fp) = "~/" ++ fp++-- | A file system root can be interpreted as an (absolute) FilePath+class FsRoot root where+  toAbsoluteFilePath :: Path root -> IO FilePath++instance FsRoot Relative where+    toAbsoluteFilePath (Path fp) = go fp+      where+        go :: FilePath -> IO FilePath+#if MIN_VERSION_directory(1,2,2)+        go = Dir.makeAbsolute+#else+        -- copied implementation from the directory package+        go = (FP.normalise <$>) . absolutize+        absolutize path -- avoid the call to `getCurrentDirectory` if we can+          | FP.isRelative path = (FP.</> path) . FP.addTrailingPathSeparator <$>+                                 Dir.getCurrentDirectory+          | otherwise          = return path+#endif++instance FsRoot Absolute where+    toAbsoluteFilePath (Path fp) = return fp++instance FsRoot HomeDir where+    toAbsoluteFilePath (Path fp) = do+      home <- Dir.getHomeDirectory+      return $ home FP.</> fp++-- | Abstract over a file system root+--+-- see 'fromFilePath'+data FsPath = forall root. FsRoot root => FsPath (Path root)++{-------------------------------------------------------------------------------+  Conversions+-------------------------------------------------------------------------------}++toFilePath :: Path Absolute -> FilePath+toFilePath (Path fp) = fp++fromFilePath :: FilePath -> FsPath+fromFilePath fp+    | FP.isAbsolute      fp = FsPath (Path fp  :: Path Absolute)+    | Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir)+    | otherwise             = FsPath (Path fp  :: Path Relative)+  where+    -- TODO: I don't know if there a standard way that Windows users refer to+    -- their home directory. For now, we'll only interpret '~'. Everybody else+    -- can specify an absolute path if this doesn't work.+    atHome :: FilePath -> Maybe FilePath+    atHome "~" = Just ""+    atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp'+    atHome _otherwise = Nothing++makeAbsolute :: FsPath -> IO (Path Absolute)+makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p++fromAbsoluteFilePath :: FilePath -> Path Absolute+fromAbsoluteFilePath fp+  | FP.isAbsolute fp = Path fp+  | otherwise        = error "fromAbsoluteFilePath: not an absolute path"++{-------------------------------------------------------------------------------+  Wrappers around System.IO+-------------------------------------------------------------------------------}++-- | Wrapper around 'withFile'+withFile :: FsRoot root => Path root -> IOMode -> (Handle -> IO r) -> IO r+withFile path mode callback = do+    filePath <- toAbsoluteFilePath path+    IO.withFile filePath mode callback++-- | Wrapper around 'openBinaryTempFileWithDefaultPermissions'+--+-- NOTE: The caller is responsible for cleaning up the temporary file.+openTempFile' :: FsRoot root => Path root -> String -> IO (Path Absolute, Handle)+openTempFile' path template = do+    filePath <- toAbsoluteFilePath path+    (tempFilePath, h) <- IO.openBinaryTempFileWithDefaultPermissions filePath template+    return (fromAbsoluteFilePath tempFilePath, h)++{-------------------------------------------------------------------------------+  Wrappers around Data.ByteString.*+-------------------------------------------------------------------------------}++readLazyByteString :: FsRoot root => Path root -> IO BS.L.ByteString+readLazyByteString path = do+    filePath <- toAbsoluteFilePath path+    BS.L.readFile filePath++readStrictByteString :: FsRoot root => Path root -> IO BS.ByteString+readStrictByteString path = do+    filePath <- toAbsoluteFilePath path+    BS.readFile filePath++writeLazyByteString :: FsRoot root => Path root -> BS.L.ByteString -> IO ()+writeLazyByteString path bs = do+    filePath <- toAbsoluteFilePath path+    BS.L.writeFile filePath bs++writeStrictByteString :: FsRoot root => Path root -> BS.ByteString -> IO ()+writeStrictByteString path bs = do+    filePath <- toAbsoluteFilePath path+    BS.writeFile filePath bs++{-------------------------------------------------------------------------------+  Wrappers around System.Directory+-------------------------------------------------------------------------------}++copyFile :: (FsRoot root, FsRoot root') => Path root -> Path root' -> IO ()+copyFile src dst = do+    src' <- toAbsoluteFilePath src+    dst' <- toAbsoluteFilePath dst+    Dir.copyFile src' dst'++createDirectory :: FsRoot root => Path root -> IO ()+createDirectory path = Dir.createDirectory =<< toAbsoluteFilePath path++createDirectoryIfMissing :: FsRoot root => Bool -> Path root -> IO ()+createDirectoryIfMissing createParents path = do+    filePath <- toAbsoluteFilePath path+    Dir.createDirectoryIfMissing createParents filePath++removeDirectory :: FsRoot root => Path root -> IO ()+removeDirectory path = Dir.removeDirectory =<< toAbsoluteFilePath path++doesFileExist :: FsRoot root => Path root -> IO Bool+doesFileExist path = do+    filePath <- toAbsoluteFilePath path+    Dir.doesFileExist filePath++doesDirectoryExist :: FsRoot root => Path root -> IO Bool+doesDirectoryExist path = do+    filePath <- toAbsoluteFilePath path+    Dir.doesDirectoryExist filePath++removeFile :: FsRoot root => Path root -> IO ()+removeFile path = do+    filePath <- toAbsoluteFilePath path+    Dir.removeFile filePath++getTemporaryDirectory :: IO (Path Absolute)+getTemporaryDirectory = fromAbsoluteFilePath <$> Dir.getTemporaryDirectory++-- | Return the immediate children of a directory+--+-- Filters out @"."@ and @".."@.+getDirectoryContents :: FsRoot root => Path root -> IO [Path Unrooted]+getDirectoryContents path = do+    filePath <- toAbsoluteFilePath path+    fragments <$> Dir.getDirectoryContents filePath+  where+    fragments :: [String] -> [Path Unrooted]+    fragments = map fromUnrootedFilePath . filter (not . skip)++    skip :: String -> Bool+    skip "."  = True+    skip ".." = True+    skip _    = False++-- | Recursive traverse a directory structure+--+-- Returns a set of paths relative to the directory specified. The list is+-- lazily constructed, so that directories are only read when required.+-- (This is also essential to ensure that this function does not build the+-- entire result in memory before returning, potentially running out of heap.)+getRecursiveContents :: FsRoot root => Path root -> IO [Path Unrooted]+getRecursiveContents root = go emptyPath+  where+    go :: Path Unrooted -> IO [Path Unrooted]+    go subdir = unsafeInterleaveIO $ do+      entries <- getDirectoryContents (root </> subdir)+      liftM concat $ forM entries $ \entry -> do+        let path = subdir </> entry+        isDirectory <- doesDirectoryExist (root </> path)+        if isDirectory then go path+                       else return [path]++    emptyPath :: Path Unrooted+    emptyPath = Path (FP.joinPath [])++renameFile :: (FsRoot root, FsRoot root')+           => Path root  -- ^ Old+           -> Path root' -- ^ New+           -> IO ()+renameFile old new = do+    old' <- toAbsoluteFilePath old+    new' <- toAbsoluteFilePath new+    Dir.renameFile old' new'++getCurrentDirectory :: IO (Path Absolute)+getCurrentDirectory = do+    cwd <- Dir.getCurrentDirectory+    makeAbsolute $ fromFilePath cwd++{-------------------------------------------------------------------------------+  Wrappers around Codec.Archive.Tar.*+-------------------------------------------------------------------------------}++data Tar++instance Pretty (Path Tar) where+  pretty (Path fp) = "<tarball>/" ++ fp++tarIndexLookup :: TarIndex.TarIndex -> Path Tar -> Maybe TarIndex.TarIndexEntry+tarIndexLookup index path = TarIndex.lookup index path'+  where+    path' :: FilePath+    path' = toUnrootedFilePath $ unrootPath path++tarAppend :: (FsRoot root, FsRoot root')+          => Path root   -- ^ Path of the @.tar@ file+          -> Path root'  -- ^ Base directory+          -> [Path Tar]  -- ^ Files to add, relative to the base dir+          -> IO ()+tarAppend tarFile baseDir contents = do+    tarFile' <- toAbsoluteFilePath tarFile+    baseDir' <- toAbsoluteFilePath baseDir+    Tar.append tarFile' baseDir' contents'+  where+    contents' :: [FilePath]+    contents' = map (toUnrootedFilePath . unrootPath) contents++{-------------------------------------------------------------------------------+  Wrappers around Network.URI+-------------------------------------------------------------------------------}++data Web++toURIPath :: FilePath -> Path Web+toURIPath = rootPath . fromUnrootedFilePath++fromURIPath :: Path Web -> FilePath+fromURIPath = toUnrootedFilePath . unrootPath++uriPath :: URI.URI -> Path Web+uriPath = toURIPath . URI.uriPath++modifyUriPath :: URI.URI -> (Path Web -> Path Web) -> URI.URI+modifyUriPath uri f = uri { URI.uriPath = f' (URI.uriPath uri) }+  where+    f' :: FilePath -> FilePath+    f' = fromURIPath . f . toURIPath++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++liftFP :: (FilePath -> FilePath) -> Path a -> Path b+liftFP f (Path fp) = Path (f fp)++liftFP2 :: (FilePath -> FilePath -> FilePath) -> Path a -> Path b -> Path c+liftFP2 f (Path fp) (Path fp') = Path (f fp fp')++liftFromFP :: (FilePath -> x) -> Path a -> x+liftFromFP f (Path fp) = f fp++liftFromFP2 :: (FilePath -> FilePath -> x) -> Path a -> Path b -> x+liftFromFP2 f (Path fp) (Path fp') = f fp fp'++liftToFP :: (x -> FilePath) -> x -> Path a+liftToFP f x = Path (f x)
+ hackage-security/hackage-security/src/Hackage/Security/Util/Pretty.hs view
@@ -0,0 +1,8 @@+-- | Producing human-reaadable strings+module Hackage.Security.Util.Pretty (+    Pretty(..)+  ) where++-- | Produce a human-readable string+class Pretty a where+  pretty :: a -> String
+ hackage-security/hackage-security/src/Hackage/Security/Util/Some.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+-- | Hiding existentials+module Hackage.Security.Util.Some (+    Some(..)+    -- ** Equality+  , DictEq(..)+  , SomeEq(..)+    -- ** Serialization+  , DictShow(..)+  , SomeShow(..)+    -- ** Pretty-printing+  , DictPretty(..)+  , SomePretty(..)+    -- ** Type checking+  , typecheckSome+#if !MIN_VERSION_base(4,7,0)+    -- ** Compatibility with base < 4.7+  , tyConSome+#endif+  ) where++#if MIN_VERSION_base(4,7,0)+import Data.Typeable (Typeable)+#else+import qualified Data.Typeable as Typeable+#endif++import Hackage.Security.Util.TypedEmbedded+import Hackage.Security.Util.Pretty++data Some f = forall a. Some (f a)++#if MIN_VERSION_base(4,7,0)+deriving instance Typeable Some+#else+tyConSome :: Typeable.TyCon+tyConSome = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Util.Some" "Some"+#endif++{-------------------------------------------------------------------------------+  Equality on Some types++  Note that we cannot really do something similar for ordering; what value+  should we return for++  > Some (f x) `compare` Some (f x')++  where @x :: a@, @x' :: a'@ and @a /= a'@? These are incomparable.+-------------------------------------------------------------------------------}++data DictEq a where+  DictEq :: Eq a => DictEq a++-- | Type @f@ satisfies @SomeEq f@ if @f a@ satisfies @Eq@ independent of @a@+class SomeEq f where+  someEq :: DictEq (f a)++instance (Typed f, SomeEq f) => Eq (Some f) where+  Some (x :: f a) == Some (y :: f a') =+    case unify (typeOf x) (typeOf y) of+      Nothing   -> False+      Just Refl -> case someEq :: DictEq (f a) of DictEq -> x == y++{-------------------------------------------------------------------------------+  Showing Some types+-------------------------------------------------------------------------------}++data DictShow a where+  DictShow :: Show a => DictShow a++-- | Type @f@ satisfies @SomeShow f@ if @f a@ satisfies @Show@ independent of @a@+class SomeShow f where+  someShow :: DictShow (f a)++instance SomeShow f => Show (Some f) where+  show (Some (x :: f a)) =+    case someShow :: DictShow (f a) of DictShow -> show x++{-------------------------------------------------------------------------------+  Pretty-printing Some types+-------------------------------------------------------------------------------}++data DictPretty a where+  DictPretty :: Pretty a => DictPretty a++-- | Type @f@ satisfies @SomeShow f@ if @f a@ satisfies @Show@ independent of @a@+class SomePretty f where+  somePretty :: DictPretty (f a)++instance SomePretty f => Pretty (Some f) where+  pretty (Some (x :: f a)) =+    case somePretty :: DictPretty (f a) of DictPretty -> pretty x++{-------------------------------------------------------------------------------+  Typechecking Some types+-------------------------------------------------------------------------------}++typecheckSome :: Typed f => Some f -> Some (TypeOf f) -> Bool+typecheckSome (Some x) (Some typ) =+    case unify (typeOf x) typ of+      Just Refl -> True+      Nothing   -> False
+ hackage-security/hackage-security/src/Hackage/Security/Util/Stack.hs view
@@ -0,0 +1,8 @@+-- | Heterogenous lists+module Hackage.Security.Util.Stack (+    (:-)(..)+  ) where++data h :- t = h :- t+  deriving (Eq, Show)+infixr 5 :-
+ hackage-security/hackage-security/src/Hackage/Security/Util/TypedEmbedded.hs view
@@ -0,0 +1,38 @@+-- | Embedded languages with meta level types+module Hackage.Security.Util.TypedEmbedded (+    (:=:)(Refl)+  , TypeOf+  , Unify(..)+  , Typed(..)+  , AsType(..)+  ) where++-- | Type equality proofs+--+-- This is a direct copy of "type-equality:Data.Type.Equality"; if we don't+-- mind the dependency we can use that package directly.+data a :=: b where+  Refl :: a :=: a++type family TypeOf (f :: * -> *) :: * -> *++-- | Equality check that gives us a type-level equality proof.+class Unify f where+  unify :: f typ -> f typ' -> Maybe (typ :=: typ')++-- | Embedded languages with type inference+class Unify (TypeOf f) => Typed f where+  typeOf :: f typ -> TypeOf f typ++-- | Cast from one type to another+--+-- By default (for language with type inference) we just compare the types+-- returned by 'typeOf'; however, in languages in which terms can have more+-- than one type this may not be the correct definition (indeed, for such+-- languages we cannot give an instance of 'Typed').+class AsType f where+  asType :: f typ -> TypeOf f typ' -> Maybe (f typ')+  default asType :: Typed f => f typ -> TypeOf f typ' -> Maybe (f typ')+  asType x typ = case unify (typeOf x) typ of+                   Just Refl -> Just x+                   Nothing   -> Nothing
+ hackage-security/hackage-security/src/Prelude.hs view
@@ -0,0 +1,32 @@+-- | Smooth over differences between various ghc versions by making older+-- preludes look like 4.8.0+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-}+module Prelude (+    module P+#if !MIN_VERSION_base(4,8,0)+  , Applicative(..)+  , Monoid(..)+  , (<$>)+  , (<$)+  , Traversable(traverse)+  , displayException+#endif+  ) where++#if MIN_VERSION_base(4,8,0)+import "base" Prelude as P+#else+#if MIN_VERSION_base(4,6,0)+import "base" Prelude as P+#else+import "base" Prelude as P hiding (catch)+#endif+import Control.Applicative+import Control.Exception (Exception)+import Data.Monoid+import Data.Traversable (Traversable(traverse))++displayException :: Exception e => e -> String+displayException = show+#endif
+ hackage-security/hackage-security/src/Text/JSON/Canonical.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Parsec+-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015+--+--+-- Minimal implementation of Canonical JSON.+--+-- <http://wiki.laptop.org/go/Canonical_JSON>+--+-- A "canonical JSON" format is provided in order to provide meaningful and+-- repeatable hashes of JSON-encoded data. Canonical JSON is parsable with any+-- full JSON parser, but security-conscious applications will want to verify+-- that input is in canonical form before authenticating any hash or signature+-- on that input.+--+-- This implementation is derived from the json parser from the json package,+-- with simplifications to meet the Canonical JSON grammar.+--+-- TODO: Known bugs/limitations:+--+--  * Decoding/encoding Unicode code-points beyond @U+00ff@ is currently broken+--+module Text.JSON.Canonical+  ( JSValue(..)+  , Int54+  , parseCanonicalJSON+  , renderCanonicalJSON+  ) where++import Text.ParserCombinators.Parsec+         ( CharParser, (<|>), (<?>), many, between, sepBy+         , satisfy, char, string, digit, spaces+         , parse )+import Control.Arrow (first)+import Data.Bits (Bits)+#if MIN_VERSION_base(4,7,0)+import Data.Bits (FiniteBits)+#endif+import Data.Char (isDigit, digitToInt)+import Data.Data (Data)+import Data.Function (on)+import Data.Int (Int64)+import Data.Ix (Ix)+import Data.List (foldl', sortBy)+import Data.Typeable (Typeable)+import Foreign.Storable (Storable)+import Text.Printf (PrintfArg)+import qualified Data.ByteString.Lazy.Char8 as BS++data JSValue+    = JSNull+    | JSBool     !Bool+    | JSNum      !Int54+    | JSString   String+    | JSArray    [JSValue]+    | JSObject   [(String, JSValue)]+    deriving (Show, Read, Eq, Ord)++-- | 54-bit integer values+--+-- JavaScript can only safely represent numbers between @-(2^53 - 1)@ and+-- @2^53 - 1@.+--+-- TODO: Although we introduce the type here, we don't actually do any bounds+-- checking and just inherit all type class instance from Int64. We should+-- probably define `fromInteger` to do bounds checking, give different instances+-- for type classes such as `Bounded` and `FiniteBits`, etc.+newtype Int54 = Int54 { int54ToInt64 :: Int64 }+  deriving ( Bounded+           , Enum+           , Eq+           , Integral+           , Data+           , Num+           , Ord+           , Real+           , Ix+#if MIN_VERSION_base(4,7,0)+           , FiniteBits+#endif+           , Bits+           , Storable+           , PrintfArg+           , Typeable+           )++instance Show Int54 where+  show = show . int54ToInt64++instance Read Int54 where+  readsPrec p = map (first Int54) . readsPrec p++------------------------------------------------------------------------------++-- | Encode as \"Canonical\" JSON.+--+-- NB: Canonical JSON's string escaping rules deviate from RFC 7159+-- JSON which requires+--+--    "All Unicode characters may be placed within the quotation+--    marks, except for the characters that must be escaped: quotation+--    mark, reverse solidus, and the control characters (@U+0000@+--    through @U+001F@)."+--+-- Whereas the current specification of Canonical JSON explicitly+-- requires to violate this by only escaping the quotation mark and+-- the reverse solidus. This, however, contradicts Canonical JSON's+-- statement that "Canonical JSON is parsable with any full JSON+-- parser"+--+-- Consequently, Canonical JSON is not a proper subset of RFC 7159.+renderCanonicalJSON :: JSValue -> BS.ByteString+renderCanonicalJSON v = BS.pack (s_value v [])++s_value :: JSValue -> ShowS+s_value JSNull         = showString "null"+s_value (JSBool False) = showString "false"+s_value (JSBool True)  = showString "true"+s_value (JSNum n)      = shows n+s_value (JSString s)   = s_string s+s_value (JSArray vs)   = s_array  vs+s_value (JSObject fs)  = s_object (sortBy (compare `on` fst) fs)++s_string :: String -> ShowS+s_string s = showChar '"' . showl s+  where showl []     = showChar '"'+        showl (c:cs) = s_char c . showl cs++        s_char '"'   = showChar '\\' . showChar '"'+        s_char '\\'  = showChar '\\' . showChar '\\'+        s_char c     = showChar c++s_array :: [JSValue] -> ShowS+s_array []           = showString "[]"+s_array (v0:vs0)     = showChar '[' . s_value v0 . showl vs0+  where showl []     = showChar ']'+        showl (v:vs) = showChar ',' . s_value v . showl vs++s_object :: [(String, JSValue)] -> ShowS+s_object []               = showString "{}"+s_object ((k0,v0):kvs0)   = showChar '{' . s_string k0+                          . showChar ':' . s_value v0+                          . showl kvs0+  where showl []          = showChar '}'+        showl ((k,v):kvs) = showChar ',' . s_string k+                          . showChar ':' . s_value v+                          . showl kvs++------------------------------------------------------------------------------++parseCanonicalJSON :: BS.ByteString -> Either String JSValue+parseCanonicalJSON = either (Left . show) Right+                   . parse p_value ""+                   . BS.unpack++p_value :: CharParser () JSValue+p_value = spaces *> p_jvalue++tok              :: CharParser () a -> CharParser () a+tok p             = p <* spaces++{-+value:+   string+   number+   object+   array+   true+   false+   null+-}+p_jvalue         :: CharParser () JSValue+p_jvalue          =  (JSNull      <$  p_null)+                 <|> (JSBool      <$> p_boolean)+                 <|> (JSArray     <$> p_array)+                 <|> (JSString    <$> p_string)+                 <|> (JSObject    <$> p_object)+                 <|> (JSNum       <$> p_number)+                 <?> "JSON value"++p_null           :: CharParser () ()+p_null            = tok (string "null") >> return ()++p_boolean        :: CharParser () Bool+p_boolean         = tok+                      (  (True  <$ string "true")+                     <|> (False <$ string "false")+                      )+{-+array:+   []+   [ elements ]+elements:+   value+   value , elements+-}+p_array          :: CharParser () [JSValue]+p_array           = between (tok (char '[')) (tok (char ']'))+                  $ p_jvalue `sepBy` tok (char ',')++{-+string:+   ""+   " chars "+chars:+   char+   char chars+char:+   any byte except hex 22 (") or hex 5C (\)+   \\+   \"+-}+p_string         :: CharParser () String+p_string          = between (tok (char '"')) (tok (char '"')) (many p_char)+  where p_char    =  (char '\\' >> p_esc)+                 <|> (satisfy (\x -> x /= '"' && x /= '\\'))++        p_esc     =  ('"'   <$ char '"')+                 <|> ('\\'  <$ char '\\')+                 <?> "escape character"+{-+object:+    {}+    { members }+members:+   pair+   pair , members+pair:+   string : value+-}+p_object         :: CharParser () [(String,JSValue)]+p_object          = between (tok (char '{')) (tok (char '}'))+                  $ p_field `sepBy` tok (char ',')+  where p_field   = (,) <$> (p_string <* tok (char ':')) <*> p_jvalue++{-+number:+   int+int:+   digit+   digit1-9 digits+   - digit1-9+   - digit1-9 digits+digits:+   digit+   digit digits+-}++-- | Parse an int+--+-- TODO: Currently this allows for a maximum of 15 digits (i.e. a maximum value+-- of @999,999,999,999,999@) as a crude approximation of the 'Int54' range.+p_number         :: CharParser () Int54+p_number          = tok+                      (  (char '-' *> (negate <$> pnat))+                     <|> pnat+                     <|> zero+                      )+  where pnat      = (\d ds -> strToInt (d:ds)) <$> digit19 <*> manyN 14 digit+        digit19   = satisfy (\c -> isDigit c && c /= '0') <?> "digit"+        strToInt  = foldl' (\x d -> 10*x + digitToInt54 d) 0+        zero      = 0 <$ char '0'++digitToInt54 :: Char -> Int54+digitToInt54 = fromIntegral . digitToInt++manyN :: Int -> CharParser () a -> CharParser () [a]+manyN 0 _ =  pure []+manyN n p =  ((:) <$> p <*> manyN (n-1) p)+         <|> pure []
+ hackage-security/hackage-security/tests/TestSuite.hs view
@@ -0,0 +1,434 @@+module Main (main) where++-- stdlib+import Control.Exception+import Control.Monad+import Data.Maybe (fromJust)+import Data.Time+import Network.URI (URI, parseURI)+import Test.Tasty+import Test.Tasty.HUnit+import System.IO.Temp (withSystemTempDirectory)++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Repository+import Hackage.Security.JSON (DeserializationError(..))+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Path+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Client.Repository.Remote as Remote+import qualified Hackage.Security.Client.Repository.Cache  as Cache++-- TestSuite+import TestSuite.HttpMem+import TestSuite.InMemCache+import TestSuite.InMemRepo+import TestSuite.InMemRepository+import TestSuite.PrivateKeys+import TestSuite.Util.StrictMVar++{-------------------------------------------------------------------------------+  TestSuite driver+-------------------------------------------------------------------------------}++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "hackage-security" [+      testGroup "InMem" [+          testCase "testInMemInitialHasForUpdates" testInMemInitialHasUpdates+        , testCase "testInMemNoUpdates"            testInMemNoUpdates+        , testCase "testInMemUpdatesAfterCron"     testInMemUpdatesAfterCron+        , testCase "testInMemKeyRollover"          testInMemKeyRollover+        , testCase "testInMemOutdatedTimestamp"    testInMemOutdatedTimestamp+        ]+    , testGroup "HttpMem" [+          testCase "testHttpMemInitialHasForUpdates" testHttpMemInitialHasUpdates+        , testCase "testHttpMemNoUpdates"            testHttpMemNoUpdates+        , testCase "testHttpMemUpdatesAfterCron"     testHttpMemUpdatesAfterCron+        , testCase "testHttpMemKeyRollover"          testHttpMemKeyRollover+        , testCase "testHttpMemOutdatedTimestamp"    testHttpMemOutdatedTimestamp+        ]+  ]++{-------------------------------------------------------------------------------+  In-memory tests++  These tests test the core TUF infrastructure, but any specific Repository+  implementation; instead, they use one specifically designed for testing+  (almost a Repository mock-up).+-------------------------------------------------------------------------------}++-- | Initial check for updates: empty cache+testInMemInitialHasUpdates :: Assertion+testInMemInitialHasUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs [] $+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry++-- | Check that if we run updates again, with no changes on the server,+-- we get NoUpdates+testInMemNoUpdates :: Assertion+testInMemNoUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs [] $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs [] $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++-- | Test that we have updates reported after the timestamp is resigned+testInMemUpdatesAfterCron :: Assertion+testInMemUpdatesAfterCron = inMemTest $ \inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs [] $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs [] $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    inMemRepoCron inMemRepo =<< getCurrentTime++    withAssertLog "C" logMsgs [] $ do+      assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "D" logMsgs [] $ do+      assertEqual "D.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++-- | Test what happens when the timestamp/snapshot keys rollover+testInMemKeyRollover :: Assertion+testInMemKeyRollover = inMemTest $ \inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs [] $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs [] $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    inMemRepoKeyRollover inMemRepo =<< getCurrentTime++    let msgs = [verificationError $ unknownKeyError timestampPath]+    withAssertLog "C" logMsgs msgs $ do+      assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "D" logMsgs [] $ do+      assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry++-- | Test what happens when server has an outdated timestamp+-- (after a successful initial update)+testInMemOutdatedTimestamp :: Assertion+testInMemOutdatedTimestamp = inMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs [] $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs [] $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    now <- getCurrentTime+    let (FileExpires fourDaysLater) = expiresInDays now 4++    let msgs = replicate 5 (inHistory (Right (expired timestampPath)))+    catchVerificationLoop msgs $ do+      withAssertLog "C" logMsgs [] $ do+        assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater++{-------------------------------------------------------------------------------+  Same tests, but going through the "real" Remote repository and Cache, though+  still using an in-memory repository (with a HttpLib bridge)++  These are almost hte same as the in-memory tests, but the log messages we+  expect are slightly different because the Remote repository indicates what+  is is downloading, and why.+-------------------------------------------------------------------------------}++-- | Initial check for updates: empty cache+testHttpMemInitialHasUpdates :: Assertion+testHttpMemInitialHasUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs msgsInitialUpdate $+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry++-- | Check that if we run updates again, with no changes on the server,+-- we get NoUpdates+testHttpMemNoUpdates :: Assertion+testHttpMemNoUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs msgsInitialUpdate $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs msgsNoUpdates $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++-- | Test that we have updates reported after the timestamp is resigned+testHttpMemUpdatesAfterCron :: Assertion+testHttpMemUpdatesAfterCron = httpMemTest $ \inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs msgsInitialUpdate $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs msgsNoUpdates $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    inMemRepoCron inMemRepo =<< getCurrentTime++    withAssertLog "C" logMsgs msgsResigned $ do+      assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "D" logMsgs msgsNoUpdates $ do+      assertEqual "D.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++-- | Test what happens when the timestamp/snapshot keys rollover+testHttpMemKeyRollover :: Assertion+testHttpMemKeyRollover = httpMemTest $ \inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs msgsInitialUpdate $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs msgsNoUpdates $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    inMemRepoKeyRollover inMemRepo =<< getCurrentTime++    withAssertLog "C" logMsgs msgsKeyRollover $ do+      assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "D" logMsgs msgsNoUpdates $ do+      assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry++-- | Test what happens when server has an outdated timestamp+-- (after a successful initial update)+testHttpMemOutdatedTimestamp :: Assertion+testHttpMemOutdatedTimestamp = httpMemTest $ \_inMemRepo logMsgs repo -> do+    withAssertLog "A" logMsgs msgsInitialUpdate $ do+      assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    withAssertLog "B" logMsgs msgsNoUpdates $ do+      assertEqual "B.2" NoUpdates  =<< checkForUpdates repo =<< checkExpiry++    now <- getCurrentTime+    let (FileExpires fourDaysLater) = expiresInDays now 4++    let msgs = replicate 5 (inHistory (Right (expired timestampPath)))+    catchVerificationLoop msgs $ do+      withAssertLog "C" logMsgs [] $ do+        assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater++{-------------------------------------------------------------------------------+  Log messages we expect when using the Remote repository+-------------------------------------------------------------------------------}++-- | The log messages we expect on the initial check for updates+msgsInitialUpdate :: [LogMessage -> Bool]+msgsInitialUpdate = [+      selectedMirror inMemURI+    , downloading isTimestamp+    , downloading isSnapshot+    , downloading isMirrors+    , noLocalCopy+    , downloading isIndex+    ]++-- | Log messages when we do a check for updates and there are no changes+msgsNoUpdates :: [LogMessage -> Bool]+msgsNoUpdates = [+      selectedMirror inMemURI+    , downloading isTimestamp+    ]++-- | Log messages we expect when the timestamp and snapshot have been resigned+msgsResigned :: [LogMessage -> Bool]+msgsResigned = [+      selectedMirror inMemURI+    , downloading isTimestamp+    , downloading isSnapshot+    ]++-- | Log messages we expect when the timestamp key has been rolled over+msgsKeyRollover :: [LogMessage -> Bool]+msgsKeyRollover = [+      selectedMirror inMemURI+    , downloading isTimestamp+    , verificationError $ unknownKeyError timestampPath+    , downloading isRoot+    , downloading isTimestamp+    , downloading isSnapshot+    -- Since we delete the timestamp and snapshot on a root info change,+    -- we will then conclude that we need to update the mirrors and the index.+    , downloading isMirrors+    , updating isIndex+    ]++{-------------------------------------------------------------------------------+  Classifying log messages+-------------------------------------------------------------------------------}++downloading :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool+downloading isFile (LogDownloading file) = isFile file+downloading _ _ = False++noLocalCopy :: LogMessage -> Bool+noLocalCopy (LogCannotUpdate (RemoteIndex _ _) UpdateImpossibleNoLocalCopy) = True+noLocalCopy _ = False++selectedMirror :: URI -> LogMessage -> Bool+selectedMirror mirror (LogSelectedMirror mirror') = mirror' == show mirror+selectedMirror _ _ = False++updating :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool+updating isFile (LogUpdating file) = isFile file+updating _ _ = False++expired :: TargetPath -> VerificationError -> Bool+expired f (VerificationErrorExpired f') = f == f'+expired _ _ = False++unknownKeyError :: TargetPath -> VerificationError -> Bool+unknownKeyError f (VerificationErrorDeserialization f' (DeserializationErrorUnknownKey _keyId)) =+    f == f'+unknownKeyError _ _ = False++verificationError :: (VerificationError -> Bool) -> LogMessage -> Bool+verificationError isErr (LogVerificationError err) = isErr err+verificationError _ _ = False++inHistory :: Either RootUpdated (VerificationError -> Bool) -> HistoryMsg -> Bool+inHistory (Right isErr) (Right err) = isErr err+inHistory (Left _)      (Left _)    = True+inHistory _             _           = False++type HistoryMsg = Either RootUpdated VerificationError++catchVerificationLoop :: ([HistoryMsg -> Bool]) -> Assertion -> Assertion+catchVerificationLoop history = handleJust isLoop handler+  where+    isLoop :: VerificationError -> Maybe VerificationHistory+    isLoop (VerificationErrorLoop history') = Just history'+    isLoop _ = Nothing++    handler :: VerificationHistory -> Assertion+    handler history' =+      unless (length history == length history' && and (zipWith ($) history history')) $+        assertFailure $ "Unexpected verification history:"+                     ++ unlines (map pretty' history')++    pretty' :: HistoryMsg -> String+    pretty' (Left RootUpdated) = "root updated"+    pretty' (Right err)        = pretty err++{-------------------------------------------------------------------------------+  Classifying files+-------------------------------------------------------------------------------}++isRoot :: RemoteFile fs typ -> Bool+isRoot (RemoteRoot _) = True+isRoot _ = False++isIndex :: RemoteFile fs typ -> Bool+isIndex (RemoteIndex _ _) = True+isIndex _ = False++isMirrors :: RemoteFile fs typ -> Bool+isMirrors (RemoteMirrors _) = True+isMirrors _ = False++isSnapshot :: RemoteFile fs typ -> Bool+isSnapshot (RemoteSnapshot _) = True+isSnapshot _ = False++isTimestamp :: RemoteFile fs typ -> Bool+isTimestamp RemoteTimestamp = True+isTimestamp _ = False++timestampPath :: TargetPath+timestampPath = TargetPathRepo $ repoLayoutTimestamp hackageRepoLayout++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Check the contents of the log+assertLog :: String -> [LogMessage -> Bool] -> [LogMessage] -> Assertion+assertLog label expected actual = go expected actual+  where+    go :: [LogMessage -> Bool] -> [LogMessage] -> Assertion+    go []     []     = return ()+    go []     as     = unexpected as+    go (_:_)  []     = assertFailure $ label ++ ": expected log message"+    go (e:es) (a:as) = if e a then go es as else unexpected [a]++    unexpected :: [LogMessage] -> Assertion+    unexpected msgs = assertFailure $ label ++ ": "+                                   ++ "unexpected log messages:\n"+                                   ++ unlines (map pretty msgs)+                                   ++ "\nfull set of log messages was:\n"+                                   ++ unlines (map pretty actual)++-- | Run the actions and check its log messages+withAssertLog :: String+              -> MVar [LogMessage]+              -> [LogMessage -> Bool]+              -> Assertion -> Assertion+withAssertLog label mv expected action = do+    oldMsgs <- modifyMVar mv $ \old -> return ([], old)+    action+    newMsgs <- modifyMVar mv $ \new -> return (oldMsgs, new)+    assertLog label expected newMsgs++-- | Unit test using the in-memory repository/cache+inMemTest :: ( ( Throws SomeRemoteError+               , Throws VerificationError+               ) => InMemRepo -> MVar [LogMessage] -> Repository InMemFile -> Assertion+             )+          -> Assertion+inMemTest test = uncheckClientErrors $ do+    now  <- getCurrentTime+    keys <- createPrivateKeys+    let root = initRoot now layout keys+    withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do+      tempDir    <- makeAbsolute $ fromFilePath tempDir'+      inMemRepo  <- newInMemRepo  layout root now keys+      inMemCache <- newInMemCache tempDir layout+      logMsgs    <- newMVar []++      let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg]+      repository <- newInMemRepository layout hackageIndexLayout inMemRepo inMemCache logger++      bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2)+      test inMemRepo logMsgs repository+  where+    layout :: RepoLayout+    layout = hackageRepoLayout++-- | Unit test using the Remote repository but with the in-mem repo+httpMemTest :: ( ( Throws SomeRemoteError+                 , Throws VerificationError+                 ) => InMemRepo -> MVar [LogMessage] -> Repository Remote.RemoteTemp -> Assertion+               )+            -> Assertion+httpMemTest test = uncheckClientErrors $ do+    now  <- getCurrentTime+    keys <- createPrivateKeys+    let root = initRoot now layout keys+    withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do+      tempDir    <- makeAbsolute $ fromFilePath tempDir'+      inMemRepo  <- newInMemRepo layout root now keys+      logMsgs    <- newMVar []++      let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg]+          httpLib    = httpMem inMemRepo+          cache      = Cache.Cache {+                           cacheRoot   = tempDir </> fragment "cache"+                         , cacheLayout = cabalCacheLayout+                         }++      Remote.withRepository httpLib+                            [inMemURI]+                            Remote.defaultRepoOpts+                            cache+                            hackageRepoLayout+                            hackageIndexLayout+                            logger+                            $ \repository -> do+        withAssertLog "bootstrap" logMsgs bootstrapMsgs $+          bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2)+        test inMemRepo logMsgs repository+  where+    bootstrapMsgs :: [LogMessage -> Bool]+    bootstrapMsgs = [ selectedMirror inMemURI+                    , downloading isRoot+                    ]++    layout :: RepoLayout+    layout = hackageRepoLayout++-- | Base URI for the in-memory repository+--+-- This could really be anything at all+inMemURI :: URI+inMemURI = fromJust (parseURI "inmem://")++-- | Return @Just@ the current time+checkExpiry :: IO (Maybe UTCTime)+checkExpiry = Just `fmap` getCurrentTime
+ hackage-security/hackage-security/tests/TestSuite/HttpMem.hs view
@@ -0,0 +1,70 @@+-- | HttpLib bridge to the in-memory repository+module TestSuite.HttpMem (+    httpMem+  ) where++-- stdlib+import Network.URI (URI)+import qualified Data.ByteString.Lazy as BS.L++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Path+import Hackage.Security.Util.Some++-- TestSuite+import TestSuite.InMemRepo++httpMem :: InMemRepo -> HttpLib+httpMem inMemRepo = HttpLib {+      httpGet      = get      inMemRepo+    , httpGetRange = getRange inMemRepo+    }++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++-- | Download a file+--+-- Since we don't (yet?) make any attempt to simulate a cache, we ignore+-- caching headers.+get :: forall a. Throws SomeRemoteError+    => InMemRepo+    -> [HttpRequestHeader]+    -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get InMemRepo{..} _requestHeaders uri callback = do+    Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)+    br <- bodyReaderFromBS $ inMemFileRender inMemFile+    callback [HttpResponseAcceptRangesBytes] br++-- | Download a byte range+--+-- Range is starting and (exclusive) end offset in bytes.+--+-- We ignore requests for compression; different servers deal with compression+-- for byte range requests differently; in particular, Apache returns the range+-- of the _compressed_ file, which is pretty useless for our purposes. For now+-- we ignore this issue completely here.+getRange :: forall a. Throws SomeRemoteError+         => InMemRepo+         -> [HttpRequestHeader]+         -> URI+         -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange InMemRepo{..} _requestHeaders uri (fr, to) callback = do+    Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)+    br <- bodyReaderFromBS $ substr (inMemFileRender inMemFile)++    let responseHeaders = concat [+            [ HttpResponseAcceptRangesBytes ]+          ]+    callback HttpStatus206PartialContent responseHeaders br+  where+    substr :: BS.L.ByteString -> BS.L.ByteString+    substr = BS.L.take (fromIntegral (to - fr)) . BS.L.drop (fromIntegral fr)
+ hackage-security/hackage-security/tests/TestSuite/InMemCache.hs view
@@ -0,0 +1,149 @@+module TestSuite.InMemCache (+    InMemCache(..)+  , newInMemCache+  ) where++-- base+import Control.Exception+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy   as BS.L++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.JSON+import Hackage.Security.Util.Path++-- TestSuite+import TestSuite.Util.StrictMVar+import TestSuite.InMemRepo++data InMemCache = InMemCache {+      inMemCacheGet     :: CachedFile -> IO (Maybe (Path Absolute))+    , inMemCacheGetRoot :: IO (Path Absolute)+    , inMemCacheClear   :: IO ()+    , inMemCachePut     :: forall f typ. InMemFile typ -> Format f -> IsCached typ -> IO ()+    }++newInMemCache :: Path Absolute -> RepoLayout -> IO InMemCache+newInMemCache tempDir layout = do+    state <- newMVar $ initLocalState layout+    return InMemCache {+        inMemCacheGet     = get     state tempDir+      , inMemCacheGetRoot = getRoot state tempDir+      , inMemCacheClear   = clear   state+      , inMemCachePut     = put     state+      }++{-------------------------------------------------------------------------------+  "Local" state (the files we "cached")+-------------------------------------------------------------------------------}++data LocalState = LocalState {+      cacheRepoLayout :: !RepoLayout+    , cachedRoot      :: !(Maybe (Signed Root))+    , cachedMirrors   :: !(Maybe (Signed Mirrors))+    , cachedTimestamp :: !(Maybe (Signed Timestamp))+    , cachedSnapshot  :: !(Maybe (Signed Snapshot))++    -- We cache only the uncompressed index++    -- (we can unambiguously construct the @.tar@ from the @.tar.gz@,+    -- but not the other way around)+    , cachedIndex :: Maybe BS.L.ByteString+    }++cachedRoot' :: LocalState -> Signed Root+cachedRoot' LocalState{..} = needRoot cachedRoot++needRoot :: Maybe a -> a+needRoot Nothing    = error "InMemCache: no root info (did you bootstrap?)"+needRoot (Just root) = root++initLocalState :: RepoLayout -> LocalState+initLocalState layout = LocalState {+      cacheRepoLayout = layout+    , cachedRoot      = Nothing+    , cachedMirrors   = Nothing+    , cachedTimestamp = Nothing+    , cachedSnapshot  = Nothing+    , cachedIndex     = Nothing+    }++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++-- | Get a cached file (if available)+get :: MVar LocalState -> Path Absolute -> CachedFile -> IO (Maybe (Path Absolute))+get state cacheTempDir cachedFile =+      case cachedFile of+        CachedRoot      -> serve "root.json"      $ render cachedRoot+        CachedMirrors   -> serve "mirrors.json"   $ render cachedMirrors+        CachedTimestamp -> serve "timestamp.json" $ render cachedTimestamp+        CachedSnapshot  -> serve "snapshot.json"  $ render cachedSnapshot+  where+    render :: forall b. ToJSON WriteJSON b+           => (LocalState -> Maybe b)+           -> (LocalState -> Maybe BS.L.ByteString)+    render f st = renderJSON (cacheRepoLayout st) `fmap` (f st)++    serve :: String+          -> (LocalState -> Maybe BS.L.ByteString)+          -> IO (Maybe (Path Absolute))+    serve template f =+      withMVar state $ \st ->+        case f st of+          Nothing -> return Nothing+          Just bs -> do (tempFile, h) <- openTempFile' cacheTempDir template+                        BS.L.hPut h bs+                        hClose h+                        return $ Just tempFile++-- | Get the cached root+getRoot :: MVar LocalState -> Path Absolute -> IO (Path Absolute)+getRoot state cacheTempDir =+    needRoot `fmap` get state cacheTempDir CachedRoot++-- | Clear all cached data+clear :: MVar LocalState -> IO ()+clear state = modifyMVar_ state $ \st -> return st {+      cachedMirrors   = Nothing+    , cachedTimestamp = Nothing+    , cachedSnapshot  = Nothing+    , cachedIndex     = Nothing+    }++-- | Cache a previously downloaded remote file+put :: MVar LocalState -> InMemFile typ -> Format f -> IsCached typ -> IO ()+put state = put' state . inMemFileRender++put' :: MVar LocalState -> BS.L.ByteString -> Format f -> IsCached typ -> IO ()+put' state bs = go+  where+    go :: Format f -> IsCached typ -> IO ()+    go _   DontCache   = return ()+    go FUn (CacheAs f) = go' f+    go FGz (CacheAs _) = error "put: the impossible happened"+    go FUn CacheIndex  = modifyMVar_ state $ \st -> return st {+                             cachedIndex = Just bs+                           }+    go FGz CacheIndex  = modifyMVar_ state $ \st -> return st {+                             cachedIndex = Just (GZip.decompress bs)+                           }++    go' :: CachedFile -> IO ()+    go' CachedRoot      = go'' $ \x st -> st { cachedRoot      = Just x }+    go' CachedTimestamp = go'' $ \x st -> st { cachedTimestamp = Just x }+    go' CachedSnapshot  = go'' $ \x st -> st { cachedSnapshot  = Just x }+    go' CachedMirrors   = go'' $ \x st -> st { cachedMirrors   = Just x }++    go'' :: forall a. FromJSON ReadJSON_Keys_Layout a+         => (a -> LocalState -> LocalState) -> IO ()+    go'' f = do+      modifyMVar_ state $ \st@LocalState{..} -> do+        let keyEnv = rootKeys . signed . cachedRoot' $ st+        case parseJSON_Keys_Layout keyEnv cacheRepoLayout bs of+           Left  err    -> throwIO err+           Right parsed -> return $ f parsed st
+ hackage-security/hackage-security/tests/TestSuite/InMemRepo.hs view
@@ -0,0 +1,262 @@+module TestSuite.InMemRepo (+    InMemRepo(..)+  , newInMemRepo+  , initRoot+  , InMemFile(..)+  , inMemFileRender+  ) where++-- stdlib+import Control.Exception+import Data.Time+import qualified Codec.Archive.Tar      as Tar+import qualified Codec.Compression.GZip as GZip+import qualified Data.ByteString.Lazy   as BS.L++-- Cabal+import Distribution.Text++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.Client.Verify+import Hackage.Security.JSON+import Hackage.Security.Util.Path+import Hackage.Security.Util.Some++-- TestSuite+import TestSuite.PrivateKeys+import TestSuite.Util.StrictMVar++{-------------------------------------------------------------------------------+  "Files" from the in-memory repository+-------------------------------------------------------------------------------}++data InMemFile :: * -> * where+    InMemMetadata :: ToJSON WriteJSON a => RepoLayout -> a -> InMemFile Metadata+    InMemBinary   :: BS.L.ByteString -> InMemFile Binary++inMemFileRender :: InMemFile typ -> BS.L.ByteString+inMemFileRender (InMemMetadata layout file) = renderJSON layout file+inMemFileRender (InMemBinary bs)            = bs++instance DownloadedFile InMemFile where+    downloadedRead file =+      return $ inMemFileRender file++    downloadedVerify file info =+      return $ knownFileInfoEqual (fileInfo (inMemFileRender file))+                                  (trusted info)++    downloadedCopyTo file dest =+      writeLazyByteString dest (inMemFileRender file)++{-------------------------------------------------------------------------------+  In-memory repository+-------------------------------------------------------------------------------}++data InMemRepo = InMemRepo {+    -- | Get a file from the repository+    inMemRepoGet :: forall fs typ.+                    RemoteFile fs typ+                 -> Verify (Some (HasFormat fs), InMemFile typ)++    -- | Get a file, based on a path (uses hackageRepoLayout)+  , inMemRepoGetPath :: RepoPath -> IO (Some InMemFile)++    -- | Run the "cron job" on the server+    --+    -- That is, resign the timestamp and the snapshot+  , inMemRepoCron :: UTCTime -> IO ()++    -- | Rollover the timestamp and snapshot keys+  , inMemRepoKeyRollover :: UTCTime -> IO ()+  }++newInMemRepo :: RepoLayout+             -> Signed Root+             -> UTCTime+             -> PrivateKeys+             -> IO InMemRepo+newInMemRepo layout root now keys = do+    state <- newMVar $ initRemoteState now layout keys root+    return InMemRepo {+        inMemRepoGet         = get         state+      , inMemRepoGetPath     = getPath     state+      , inMemRepoCron        = cron        state+      , inMemRepoKeyRollover = keyRollover state+      }++{-------------------------------------------------------------------------------+  "Remote" state (as it is "on the server")+-------------------------------------------------------------------------------}++data RemoteState = RemoteState {+      remoteKeys      :: !PrivateKeys+    , remoteLayout    :: !RepoLayout+    , remoteRoot      :: !(Signed Root)+    , remoteTimestamp :: !(Signed Timestamp)+    , remoteSnapshot  :: !(Signed Snapshot)+    , remoteMirrors   :: !(Signed Mirrors)+    , remoteTar       :: !BS.L.ByteString+    , remoteTarGz     :: !BS.L.ByteString+    }++initRoot :: UTCTime -> RepoLayout -> PrivateKeys -> Signed Root+initRoot now layout keys = withSignatures layout (privateRoot keys) Root {+      rootVersion = FileVersion 1+    , rootExpires = expiresInDays now (365 * 10)+    , rootKeys    = privateKeysEnv   keys+    , rootRoles   = privateKeysRoles keys+    }++initRemoteState :: UTCTime+                -> RepoLayout+                -> PrivateKeys+                -> Signed Root+                -> RemoteState+initRemoteState now layout keys signedRoot = RemoteState {+      remoteKeys      = keys+    , remoteLayout    = layout+    , remoteRoot      = signedRoot+    , remoteTimestamp = signedTimestamp+    , remoteSnapshot  = signedSnapshot+    , remoteMirrors   = signedMirrors+    , remoteTar       = initTar+    , remoteTarGz     = initTarGz+    }+  where+    signedTimestamp = withSignatures layout [privateTimestamp keys] initTimestamp+    signedSnapshot  = withSignatures layout [privateSnapshot  keys] initSnapshot+    signedMirrors   = withSignatures layout [privateMirrors   keys] initMirrors++    initMirrors :: Mirrors+    initMirrors = Mirrors {+        mirrorsVersion = FileVersion 1+      , mirrorsExpires = expiresNever+      , mirrorsMirrors = []+      }++    initSnapshot :: Snapshot+    initSnapshot = Snapshot {+        snapshotVersion     = FileVersion 1+      , snapshotExpires     = expiresInDays now 3+      , snapshotInfoRoot    = fileInfo $ renderJSON layout signedRoot+      , snapshotInfoMirrors = fileInfo $ renderJSON layout signedMirrors+      , snapshotInfoTarGz   = fileInfo $ initTarGz+      , snapshotInfoTar     = Just $ fileInfo initTar+      }++    initTimestamp :: Timestamp+    initTimestamp = Timestamp {+        timestampVersion      = FileVersion 1+      , timestampExpires      = expiresInDays now 3+      , timestampInfoSnapshot = fileInfo $ renderJSON layout signedSnapshot+      }++    initTar :: BS.L.ByteString+    initTar = Tar.write []++    initTarGz :: BS.L.ByteString+    initTarGz = GZip.compress initTar++{-------------------------------------------------------------------------------+  InMemRepo methods+-------------------------------------------------------------------------------}++-- | Get a file from the server+get :: MVar RemoteState -> RemoteFile fs typ -> Verify (Some (HasFormat fs), InMemFile typ)+get state remoteFile = do+    RemoteState{..} <- liftIO $ readMVar state+    case remoteFile of+      RemoteTimestamp        -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteTimestamp)+      RemoteSnapshot       _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteSnapshot)+      RemoteMirrors        _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteMirrors)+      RemoteRoot           _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteRoot)+      RemoteIndex    hasGz _ -> return (Some hasGz, InMemBinary remoteTarGz)+      RemotePkgTarGz pkgId _ -> error $ "withRemote: RemotePkgTarGz " ++ display pkgId++getPath :: MVar RemoteState -> RepoPath -> IO (Some InMemFile)+getPath state repoPath = do+    RemoteState{..} <- readMVar state+    case toUnrootedFilePath (unrootPath repoPath) of+      "root.json"       -> return $ Some (InMemMetadata remoteLayout remoteRoot)+      "timestamp.json"  -> return $ Some (InMemMetadata remoteLayout remoteTimestamp)+      "snapshot.json"   -> return $ Some (InMemMetadata remoteLayout remoteSnapshot)+      "mirrors.json"    -> return $ Some (InMemMetadata remoteLayout remoteMirrors)+      "01-index.tar.gz" -> return $ Some (InMemBinary remoteTarGz)+      "01-index.tar"    -> return $ Some (InMemBinary remoteTar)+      otherPath -> throwIO . userError $ "getPath: Unknown path " ++ otherPath+  where++cron :: MVar RemoteState -> UTCTime -> IO ()+cron state now = modifyMVar_ state $ \st@RemoteState{..} -> do+    let snapshot, snapshot' :: Snapshot+        snapshot  = signed remoteSnapshot+        snapshot' = snapshot {+            snapshotVersion = versionIncrement $ snapshotVersion snapshot+          , snapshotExpires = expiresInDays now 3+          }++        timestamp, timestamp' :: Timestamp+        timestamp  = signed remoteTimestamp+        timestamp' = Timestamp {+            timestampVersion      = versionIncrement $ timestampVersion timestamp+          , timestampExpires      = expiresInDays now 3+          , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot+          }++        signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys] timestamp'+        signedSnapshot  = withSignatures remoteLayout [privateSnapshot  remoteKeys] snapshot'++    return st {+        remoteTimestamp = signedTimestamp+      , remoteSnapshot  = signedSnapshot+      }++keyRollover :: MVar RemoteState -> UTCTime -> IO ()+keyRollover state now = modifyMVar_ state $ \st@RemoteState{..} -> do+    newKeySnapshot  <- createKey' KeyTypeEd25519+    newKeyTimestamp <- createKey' KeyTypeEd25519++    let remoteKeys' :: PrivateKeys+        remoteKeys' = remoteKeys {+            privateSnapshot  = newKeySnapshot+          , privateTimestamp = newKeyTimestamp+          }++        root, root' :: Root+        root  = signed remoteRoot+        root' = Root {+            rootVersion = versionIncrement $ rootVersion root+          , rootExpires = expiresInDays now (365 * 10)+          , rootKeys    = privateKeysEnv   remoteKeys'+          , rootRoles   = privateKeysRoles remoteKeys'+          }++        snapshot, snapshot' :: Snapshot+        snapshot  = signed remoteSnapshot+        snapshot' = snapshot {+            snapshotVersion  = versionIncrement $ snapshotVersion snapshot+          , snapshotExpires  = expiresInDays now 3+          , snapshotInfoRoot = fileInfo $ renderJSON remoteLayout signedRoot+          }++        timestamp, timestamp' :: Timestamp+        timestamp  = signed remoteTimestamp+        timestamp' = Timestamp {+            timestampVersion      = versionIncrement $ timestampVersion timestamp+          , timestampExpires      = expiresInDays now 3+          , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot+          }++        signedRoot      = withSignatures remoteLayout (privateRoot      remoteKeys') root'+        signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys'] timestamp'+        signedSnapshot  = withSignatures remoteLayout [privateSnapshot  remoteKeys'] snapshot'++    return st {+        remoteRoot      = signedRoot+      , remoteTimestamp = signedTimestamp+      , remoteSnapshot  = signedSnapshot+      }
+ hackage-security/hackage-security/tests/TestSuite/InMemRepository.hs view
@@ -0,0 +1,63 @@+module TestSuite.InMemRepository (+    newInMemRepository+  ) where++-- stdlib+import Control.Concurrent++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Formats+import Hackage.Security.Client.Repository+import Hackage.Security.Client.Verify+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Some++-- TestSuite+import TestSuite.InMemCache+import TestSuite.InMemRepo++newInMemRepository :: RepoLayout+                   -> IndexLayout+                   -> InMemRepo+                   -> InMemCache+                   -> (LogMessage -> IO ())+                   -> IO (Repository InMemFile)+newInMemRepository layout indexLayout repo cache logger = do+    cacheLock <- newMVar ()+    return $ Repository {+        repGetRemote     = getRemote     repo cache+      , repGetCached     = inMemCacheGet      cache+      , repGetCachedRoot = inMemCacheGetRoot  cache+      , repClearCache    = inMemCacheClear    cache+      , repLockCache     = withMVar cacheLock . const+      , repWithIndex     = error "newInMemRepository: repWithIndex TODO"+      , repGetIndexIdx   = error "newInMemRepository: repGetIndexIdx TODO"+      , repWithMirror    = withMirror+      , repLog           = logger+      , repLayout        = layout+      , repIndexLayout   = indexLayout+      , repDescription   = "In memory repository"+      }++{-------------------------------------------------------------------------------+  Repository methods+-------------------------------------------------------------------------------}++-- | Get a file from the server+getRemote :: forall fs typ. Throws SomeRemoteError+          => InMemRepo+          -> InMemCache+          -> AttemptNr+          -> RemoteFile fs typ+          -> Verify (Some (HasFormat fs), InMemFile typ)+getRemote InMemRepo{..} InMemCache{..} _isRetry remoteFile = do+    (Some format, inMemFile) <- inMemRepoGet remoteFile+    ifVerified $ inMemCachePut inMemFile (hasFormatGet format) (mustCache remoteFile)+    return (Some format, inMemFile)++-- | Mirror selection+withMirror :: forall a. Maybe [Mirror] -> IO a -> IO a+withMirror Nothing   callback = callback+withMirror (Just []) callback = callback+withMirror _ _ = error "Mirror selection not implemented"
+ hackage-security/hackage-security/tests/TestSuite/PrivateKeys.hs view
@@ -0,0 +1,69 @@+module TestSuite.PrivateKeys (+    PrivateKeys(..)+  , createPrivateKeys+  , privateKeysEnv+  , privateKeysRoles+  ) where++-- stdlib+import Control.Monad++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Key.Env (KeyEnv)+import Hackage.Security.Util.Some+import qualified Hackage.Security.Key.Env as KeyEnv++{-------------------------------------------------------------------------------+  All private keys+-------------------------------------------------------------------------------}++data PrivateKeys = PrivateKeys {+      privateRoot      :: [Some Key]+    , privateTarget    :: [Some Key]+    , privateSnapshot  :: Some Key+    , privateTimestamp :: Some Key+    , privateMirrors   :: Some Key+    }++createPrivateKeys :: IO PrivateKeys+createPrivateKeys = do+    privateRoot      <- replicateM 3 $ createKey' KeyTypeEd25519+    privateTarget    <- replicateM 3 $ createKey' KeyTypeEd25519+    privateSnapshot  <- createKey' KeyTypeEd25519+    privateTimestamp <- createKey' KeyTypeEd25519+    privateMirrors   <- createKey' KeyTypeEd25519+    return PrivateKeys{..}++privateKeysEnv :: PrivateKeys -> KeyEnv+privateKeysEnv PrivateKeys{..} = KeyEnv.fromKeys $ concat [+      privateRoot+    , privateTarget+    , [privateSnapshot]+    , [privateTimestamp]+    , [privateMirrors]+    ]++privateKeysRoles :: PrivateKeys -> RootRoles+privateKeysRoles PrivateKeys{..} = RootRoles {+      rootRolesRoot      = RoleSpec {+          roleSpecKeys      = map somePublicKey privateRoot+        , roleSpecThreshold = KeyThreshold 2+        }+    , rootRolesSnapshot  = RoleSpec {+          roleSpecKeys      = [somePublicKey privateSnapshot]+        , roleSpecThreshold = KeyThreshold 1+        }+    , rootRolesTargets   = RoleSpec {+          roleSpecKeys      = map somePublicKey privateTarget+        , roleSpecThreshold = KeyThreshold 2+        }+    , rootRolesTimestamp = RoleSpec {+          roleSpecKeys      = [somePublicKey privateTimestamp]+        , roleSpecThreshold = KeyThreshold 1+        }+    , rootRolesMirrors   = RoleSpec {+          roleSpecKeys      = [somePublicKey privateMirrors]+        , roleSpecThreshold = KeyThreshold 1+        }+    }
+ hackage-security/hackage-security/tests/TestSuite/Util/StrictMVar.hs view
@@ -0,0 +1,27 @@+module TestSuite.Util.StrictMVar (+    MVar -- opaque+  , newMVar+  , CC.withMVar+  , modifyMVar+  , modifyMVar_+  , CC.readMVar+  ) where++import Control.Concurrent (MVar)+import Control.Exception+import qualified Control.Concurrent as CC++newMVar :: a -> IO (MVar a)+newMVar x = CC.newMVar =<< evaluate x++modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b+modifyMVar mv f = CC.modifyMVar mv $ \old -> do+    (new, ret) <- f old+    new' <- evaluate new+    return (new', ret)++modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVar_ mv f = modifyMVar mv (returnUnit . f)+  where+    returnUnit :: IO a -> IO (a, ())+    returnUnit = fmap $ \a -> (a, ())
+ hackage-security/precompute-fileinfo/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ hackage-security/precompute-fileinfo/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security/precompute-fileinfo/precompute-fileinfo.cabal view
@@ -0,0 +1,27 @@+name:                precompute-fileinfo+version:             0.1.0.0+synopsis:            Precompute fileinfo for faster Hackage migration+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++executable precompute-fileinfo+  main-is:             Main.hs+  build-depends:       base                 >= 4.4,+                       bytestring           >= 0.9,+                       containers           >= 0.4,+                       deepseq              >= 1.3,+                       filepath             >= 1.2,+                       optparse-applicative >= 0.11,+                       SHA                  >= 1.6,+                       tar                  >= 0.4,+                       zlib                 >= 0.5+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  RecordWildCards+  ghc-options:         -Wall
+ hackage-security/precompute-fileinfo/src/Main.hs view
@@ -0,0 +1,196 @@+module Main where++import Control.Applicative+import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Map.Strict (Map)+import Data.Monoid+import Options.Applicative+import System.FilePath+import System.IO+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip  as GZip+import qualified Data.ByteString.Lazy    as BS.L+import qualified Data.Digest.Pure.SHA    as SHA+import qualified Data.Map                as Map++{-------------------------------------------------------------------------------+  Main application driver+-------------------------------------------------------------------------------}++main :: IO ()+main = do+    options    <- getOptions+    tarEntries <- readTGz $ optionsArchive options+    state      <- initState options++    precomputeEntries state tarEntries `finally` writeState options state++{-------------------------------------------------------------------------------+  Command line options+-------------------------------------------------------------------------------}++data Options = Options {+      optionsInput   :: Maybe FilePath+    , optionsOutput  :: FilePath+    , optionsArchive :: FilePath+    }++parseOptions :: Parser Options+parseOptions = Options+  <$> (optional . strOption $ mconcat [+          short 'i'+        , long "input"+        , help "Input filename (if appending to existing map)"+        ])+  <*> (strOption $ mconcat [+          short 'o'+        , long "output"+        , help "Output filename"+        ])+  <*> argument str (metavar "ARCHIVE")++getOptions :: IO Options+getOptions = execParser opts+  where+    opts = info (helper <*> parseOptions) $ mconcat [+        fullDesc+      , progDesc "Precompute file info from a Hackage --hardlink-blobs backup"+      ]++{-------------------------------------------------------------------------------+  Core functionality+-------------------------------------------------------------------------------}++precomputeEntries :: Exception e => State -> Tar.Entries e -> IO ()+precomputeEntries state = go+  where+    go (Tar.Fail e)    = throwIO e+    go Tar.Done        = return ()+    go (Tar.Next e es) = precomputeEntry state e >> go es++precomputeEntry :: State -> Tar.Entry -> IO ()+precomputeEntry state entry =+    case Tar.entryContent entry of+      Tar.SymbolicLink linkTarget ->+        precomputeSymLink state+                          (Tar.entryPath entry)+                          (Tar.fromLinkTarget linkTarget)+      _otherwise ->+        return ()++precomputeSymLink :: State -> FilePath -> FilePath -> IO ()+precomputeSymLink state src dst =+    case splitPath src of+      [_date, "core/", "package/", pkg, _pkgTarGz] -> do+        let blobPath = normalizePath (stateBackupDir state </> takeDirectory src </> dst)+        precomputePkg state ("package " ++ init pkg) blobPath+      [_date, "candidates/", "package/", pkg, _pkgTarGz] -> do+        let blobPath = normalizePath (stateBackupDir state </> takeDirectory src </> dst)+        precomputePkg state ("candidate " ++ init pkg) blobPath+      _otherwise -> do+        return ()++precomputePkg :: State     -- ^ State to add the computed hash to+              -> String    -- ^ Package name (for reporting only)+              -> FilePath  -- ^ Location of the blob ID (ending in @../<md5>@)+              -> IO ()+precomputePkg state pkg dst = do+    putStr pkg+    let md5 = takeFileName dst+    alreadyKnown <- isKnownHash state md5+    if alreadyKnown+      then putStrLn " (skipped)"+      else do+        (sha256, len) <- withFile dst ReadMode $ \h -> do+          len    <- hFileSize h+          sha256 <- SHA.showDigest . SHA.sha256 <$> BS.L.hGetContents h+          evaluate $ rnf (sha256, len)+          return (sha256, len)+        recordHash state md5 sha256 len+        putStrLn " OK"++{-------------------------------------------------------------------------------+  State+-------------------------------------------------------------------------------}++type MD5    = String+type SHA256 = String+type Length = Integer++data State = State {+      -- | The directory where the backup is stored+      --+      -- This is necessary so we can resolve relative paths inside the tarball+      stateBackupDir :: FilePath++      -- | Mutable variable where we store the hashes computed so far+      --+      -- We use this so that even on CTRL-C we can still output a partial map+    , stateVar :: MVar (Map MD5 (SHA256, Length))+    }++initState :: Options -> IO State+initState Options{..} = do+    initMap <- case optionsInput of+                 Nothing -> return Map.empty+                 Just fn -> readMap fn+    stateVar <- newMVar initMap+    return State{..}+  where+    stateBackupDir = takeDirectory optionsArchive++writeState :: Options -> State -> IO ()+writeState Options{..} State{..} = do+    putStrLn $ "Writing " ++ optionsOutput+    writeMap optionsOutput =<< readMVar stateVar++recordHash :: State -> MD5 -> SHA256 -> Length -> IO ()+recordHash State{..} md5 sha256 len =+    modifyMVar_ stateVar $ return . Map.insert md5 (sha256, len)++isKnownHash :: State -> MD5 -> IO Bool+isKnownHash State{..} md5 = withMVar stateVar $ return . Map.member md5++writeMap :: FilePath -> Map MD5 (SHA256, Length) -> IO ()+writeMap fp hashes = withFile fp WriteMode $ \h ->+    mapM_ (uncurry (writeEntry h)) $ Map.toList hashes+  where+    writeEntry :: Handle -> MD5 -> (SHA256, Length) -> IO ()+    writeEntry h md5 (sha256, len) =+        hPutStrLn h $ unwords [md5, sha256, show len]++-- | Read an existing hashmap+--+-- The result is guaranteed to be in normal form.+readMap :: FilePath -> IO (Map MD5 (SHA256, Length))+readMap fp =+    withFile fp ReadMode $ \h -> do+      hashes <- Map.fromList . map parseEntry . lines <$> hGetContents h+      evaluate $ rnf hashes+      return hashes+  where+    parseEntry :: String -> (MD5, (SHA256, Length))+    parseEntry line = let [md5, sha256, len] = words line+                      in (md5, (sha256, read len))++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Change @a/b/c/d/e/../../../../f@ to @a/f@+normalizePath :: FilePath -> FilePath+normalizePath = joinPath . go . splitPath . normalise+  where+    go :: [String] -> [String]+    go [] = []+    go (d : ds) =+      case go ds of+        "../" : ds'' | d /= "../" -> ds''+        ds'                       -> d : ds'++readTGz :: FilePath -> IO (Tar.Entries Tar.FormatError)+readTGz = liftM (Tar.read . GZip.decompress) . BS.L.readFile
+ hackage-security/stack.yaml view
@@ -0,0 +1,13 @@+resolver: lts-3.4+packages:+- hackage-security+- precompute-fileinfo+- hackage-security-http-client+- example-client+- hackage-security-curl+- hackage-root-tool+- hackage-repo-tool+- hackage-security-HTTP+extra-deps:+- ed25519-0.0.2.0+- zlib-0.6.1.1
+ hackage-security/testscripts/squid.conf view
@@ -0,0 +1,4 @@+# Don't specify a cache dir; use in-memory cache+http_port 3128+access_log stdio:/dev/stdout combined +http_access allow all 
+ hackage-security/testscripts/test-outdated-index.log view
@@ -0,0 +1,440 @@++ BINDIR=../sandbox/7.8.3/bin++ EXAMPLE_CLIENT=../sandbox/7.8.3/bin/example-client++ SECURITY_UTILITY=../sandbox/7.8.3/bin/hackage-security++ REPO=http://127.0.0.1/~e/local-repo++ PROXY=http://localhost:3128++ LOCAL_REPO=../unversioned/local-repo++ KEYS=../unversioned/keys++ LOCAL_CACHE=./tmp++ rm -rf ../unversioned/local-repo/index++ ../sandbox/7.8.3/bin/hackage-security -v bootstrap --repo ../unversioned/local-repo --keys ../unversioned/keys+Info: Writing <repo>/root.json+Info: Writing <repo>/mirrors.json+Info: Writing <repo>/generics-sop/0.1.0.0/package.json+Info: Writing <repo>/generics-sop/0.1.0.0/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.0.0.tar.gz)+Info: Writing <repo>/generics-sop/0.1.0.1/package.json+Info: Writing <repo>/generics-sop/0.1.0.1/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.0.1.tar.gz)+Info: Writing <repo>/generics-sop/0.1.0.2/package.json+Info: Writing <repo>/generics-sop/0.1.0.2/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.0.2.tar.gz)+Info: Writing <repo>/generics-sop/0.1.0.3/package.json+Info: Writing <repo>/generics-sop/0.1.0.3/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.0.3.tar.gz)+Info: Writing <repo>/generics-sop/0.1.0.4/package.json+Info: Writing <repo>/generics-sop/0.1.0.4/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.0.4.tar.gz)+Info: Writing <repo>/generics-sop/0.1.1.1/package.json+Info: Writing <repo>/generics-sop/0.1.1.1/generics-sop.cabal (extracted from <repo>/package/generics-sop-0.1.1.1.tar.gz)+Info: Writing <repo>/generics-sop/0.1.1.2/package.json+Warning: Failed to extract .cabal from package generics-sop-0.1.1.2: <repo>/package/generics-sop-0.1.1.2.tar.gz: Codec.Compression.Zlib: compressed data stream format error (incorrect header check)+Info: Writing <repo>/pretty-show/1.4.1/package.json+Info: Writing <repo>/pretty-show/1.4.1/pretty-show.cabal (extracted from <repo>/package/pretty-show-1.4.1.tar.gz)+Info: Writing <repo>/pretty-show/1.5/package.json+Info: Writing <repo>/pretty-show/1.5/pretty-show.cabal (extracted from <repo>/package/pretty-show-1.5.tar.gz)+Info: Writing <repo>/pretty-show/1.6/package.json+Info: Writing <repo>/pretty-show/1.6/pretty-show.cabal (extracted from <repo>/package/pretty-show-1.6.tar.gz)+Info: Writing <repo>/pretty-sop/0.1.0.0/package.json+Info: Writing <repo>/pretty-sop/0.1.0.0/pretty-sop.cabal (extracted from <repo>/package/pretty-sop-0.1.0.0.tar.gz)+Info: Writing <repo>/pretty-sop/0.1.0.1/package.json+Info: Writing <repo>/pretty-sop/0.1.0.1/pretty-sop.cabal (extracted from <repo>/package/pretty-sop-0.1.0.1.tar.gz)+Info: Writing <repo>/tagged/0.6.1/package.json+Info: Writing <repo>/tagged/0.6.1/tagged.cabal (extracted from <repo>/package/tagged-0.6.1.tar.gz)+Info: Writing <repo>/tagged/0.7.1/package.json+Info: Writing <repo>/tagged/0.7.1/tagged.cabal (extracted from <repo>/package/tagged-0.7.1.tar.gz)+Info: Writing <repo>/tagged/0.7.2/package.json+Info: Writing <repo>/tagged/0.7.2/tagged.cabal (extracted from <repo>/package/tagged-0.7.2.tar.gz)+Info: Writing <repo>/tagged/0.7.3/package.json+Info: Writing <repo>/tagged/0.7.3/tagged.cabal (extracted from <repo>/package/tagged-0.7.3.tar.gz)+Info: Writing <repo>/tagged/0.8.0.1/package.json+Info: Writing <repo>/tagged/0.8.0.1/tagged.cabal (extracted from <repo>/package/tagged-0.8.0.1.tar.gz)+Info: Writing <repo>/00-index.tar+Info: Writing <repo>/00-index.tar.gz+Info: Writing <repo>/snapshot.json+Info: Writing <repo>/timestamp.json++ unset HTTP_PROXY++ unset http_proxy++ rm -rf ./tmp++ ../sandbox/7.8.3/bin/example-client --repo http://127.0.0.1/~e/local-repo --cache ./tmp bootstrap 0+# Selected mirror http://127.0.0.1/~e/local-repo+# Downloading root+Sending:+GET /~e/local-repo/root.json HTTP/1.1
+Host: 127.0.0.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+
++Creating new connection to 127.0.0.1+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"cfb-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 3323
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+
++OK++ ../sandbox/7.8.3/bin/example-client --repo http://127.0.0.1/~e/local-repo --cache ./tmp check+# Selected mirror http://127.0.0.1/~e/local-repo+# Downloading timestamp+Sending:+GET /~e/local-repo/timestamp.json HTTP/1.1
+Host: 127.0.0.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+
++Creating new connection to 127.0.0.1+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"1a3-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 419
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+
++# Downloading snapshot+Sending:+GET /~e/local-repo/snapshot.json HTTP/1.1
+Host: 127.0.0.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+
++Recovering connection to 127.0.0.1+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"319-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 793
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+
++# Downloading mirrors+Sending:+GET /~e/local-repo/mirrors.json HTTP/1.1
+Host: 127.0.0.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+
++Recovering connection to 127.0.0.1+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"2ad-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 685
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+
++# Updating index failed (no local copy)+# Downloading index+Sending:+GET /~e/local-repo/00-index.tar.gz HTTP/1.1
+Host: 127.0.0.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+
++Recovering connection to 127.0.0.1+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"1241-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 4673
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/x-gzip
+
++HasUpdates++ export HTTP_PROXY=http://localhost:3128++ HTTP_PROXY=http://localhost:3128++ export http_proxy=http://localhost:3128++ http_proxy=http://localhost:3128++ curl -Lv http://127.0.0.1/~e/local-repo/00-index.tar+* Hostname was NOT found in DNS cache+  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current+                                 Dload  Upload   Total   Spent    Left  Speed+
  0     0    0     0    0     0      0      0 --:--:-- --:--:-- --:--:--     0*   Trying 127.0.0.1...+* Connected to localhost (127.0.0.1) port 3128 (#0)+> GET http://127.0.0.1/~e/local-repo/00-index.tar HTTP/1.1
+> User-Agent: curl/7.37.1
+> Host: 127.0.0.1
+> Accept: */*
+> Proxy-Connection: Keep-Alive
+> 
+< HTTP/1.1 200 OK
+< Date: Mon, 13 Jul 2015 15:16:39 GMT
+* Server Apache/2.4.10 (Unix) is not blacklisted+< Server: Apache/2.4.10 (Unix)
+< Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+< ETag: W/"10000-51ac3355103c0"
+< Accept-Ranges: bytes
+< Content-Length: 65536
+< Cache-Control: max-age=300, public, no-transform
+< Content-Type: application/x-tar
+< X-Cache: MISS from server.local
+< Via: 1.1 server.local (squid/3.5.6)
+< Connection: keep-alive
+< 
+{ [data not shown]+
100 65536  100 65536    0     0  7622k      0 --:--:-- --:--:-- --:--:-- 8000k+* Connection #0 to host localhost left intact++ sleep 5++ dd bs=1 count=16384 if=/dev/random of=../unversioned/local-repo/index/extra-file+16384+0 records in+16384+0 records out+16384 bytes transferred in 0.050569 secs (323993 bytes/sec)++ ../sandbox/7.8.3/bin/hackage-security -v update --repo ../unversioned/local-repo --keys ../unversioned/keys+Info: Skipping <repo>/generics-sop/0.1.0.0/package.json+Info: Skipping <repo>/generics-sop/0.1.0.0/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.0.1/package.json+Info: Skipping <repo>/generics-sop/0.1.0.1/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.0.2/package.json+Info: Skipping <repo>/generics-sop/0.1.0.2/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.0.3/package.json+Info: Skipping <repo>/generics-sop/0.1.0.3/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.0.4/package.json+Info: Skipping <repo>/generics-sop/0.1.0.4/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.1.1/package.json+Info: Skipping <repo>/generics-sop/0.1.1.1/generics-sop.cabal+Info: Skipping <repo>/generics-sop/0.1.1.2/package.json+Warning: Failed to extract .cabal from package generics-sop-0.1.1.2: <repo>/package/generics-sop-0.1.1.2.tar.gz: Codec.Compression.Zlib: compressed data stream format error (incorrect header check)+Info: Skipping <repo>/pretty-show/1.4.1/package.json+Info: Skipping <repo>/pretty-show/1.4.1/pretty-show.cabal+Info: Skipping <repo>/pretty-show/1.5/package.json+Info: Skipping <repo>/pretty-show/1.5/pretty-show.cabal+Info: Skipping <repo>/pretty-show/1.6/package.json+Info: Skipping <repo>/pretty-show/1.6/pretty-show.cabal+Info: Skipping <repo>/pretty-sop/0.1.0.0/package.json+Info: Skipping <repo>/pretty-sop/0.1.0.0/pretty-sop.cabal+Info: Skipping <repo>/pretty-sop/0.1.0.1/package.json+Info: Skipping <repo>/pretty-sop/0.1.0.1/pretty-sop.cabal+Info: Skipping <repo>/tagged/0.6.1/package.json+Info: Skipping <repo>/tagged/0.6.1/tagged.cabal+Info: Skipping <repo>/tagged/0.7.1/package.json+Info: Skipping <repo>/tagged/0.7.1/tagged.cabal+Info: Skipping <repo>/tagged/0.7.2/package.json+Info: Skipping <repo>/tagged/0.7.2/tagged.cabal+Info: Skipping <repo>/tagged/0.7.3/package.json+Info: Skipping <repo>/tagged/0.7.3/tagged.cabal+Info: Skipping <repo>/tagged/0.8.0.1/package.json+Info: Skipping <repo>/tagged/0.8.0.1/tagged.cabal+Info: Appending 1 file(s) to <repo>/00-index.tar+Info: Writing <repo>/00-index.tar.gz+Info: Updating <repo>/snapshot.json+Info: Updating <repo>/timestamp.json++ ../sandbox/7.8.3/bin/example-client --repo http://127.0.0.1/~e/local-repo --cache ./tmp check+# Selected mirror http://127.0.0.1/~e/local-repo+# Downloading timestamp+Sending:+GET http://127.0.0.1/~e/local-repo/timestamp.json HTTP/1.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Creating new connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:44 GMT
+ETag: "1a3-51ac3359d4f00"
+Accept-Ranges: bytes
+Content-Length: 419
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading snapshot+Sending:+GET http://127.0.0.1/~e/local-repo/snapshot.json HTTP/1.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:44 GMT
+ETag: "31a-51ac3359d4f00"
+Accept-Ranges: bytes
+Content-Length: 794
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Updating index+Sending:+GET http://127.0.0.1/~e/local-repo/00-index.tar HTTP/1.1
+Range: bytes=64512-82431
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 206 Partial Content 
+Date: Mon, 13 Jul 2015 15:16:39 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: W/"10000-51ac3355103c0"
+Accept-Ranges: bytes
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/x-tar
+Age: 6
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+Content-Range: bytes 64512-65535/65536
+Content-Length: 1024
+
++# Verification error: Invalid hash for <repo>/00-index.tar+# Downloading root+Sending:+GET http://127.0.0.1/~e/local-repo/root.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:39 GMT
+ETag: "cfb-51ac3355103c0"
+Accept-Ranges: bytes
+Content-Length: 3323
+Cache-Control: max-age=300, public, no-transform
+Content-Type: application/json
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading timestamp+Sending:+GET http://127.0.0.1/~e/local-repo/timestamp.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Last-Modified: Mon, 13 Jul 2015 15:16:44 GMT
+Accept-Ranges: bytes
+Content-Length: 419
+Content-Type: application/json
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+ETag: "1a3-51ac3359d4f00"
+Cache-Control: max-age=300, public, no-transform
+Age: 0
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading snapshot+Sending:+GET http://127.0.0.1/~e/local-repo/snapshot.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Last-Modified: Mon, 13 Jul 2015 15:16:44 GMT
+Accept-Ranges: bytes
+Content-Length: 794
+Content-Type: application/json
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+ETag: "31a-51ac3359d4f00"
+Cache-Control: max-age=300, public, no-transform
+Age: 0
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Updating index+Sending:+GET http://127.0.0.1/~e/local-repo/00-index.tar HTTP/1.1
+Range: bytes=64512-82431
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 206 Partial Content 
+Date: Mon, 13 Jul 2015 15:16:45 GMT
+Server: Apache/2.4.10 (Unix)
+Last-Modified: Mon, 13 Jul 2015 15:16:44 GMT
+ETag: "14200-51ac3359d4f00"
+Accept-Ranges: bytes
+Content-Length: 17920
+Cache-Control: max-age=300, public, no-transform
+Content-Range: bytes 64512-82431/82432
+Content-Type: application/x-tar
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++HasUpdates
+ hackage-security/testscripts/test-outdated-index.sh view
@@ -0,0 +1,67 @@+#!/bin/bash++##+# Cache incoherence test 2: outdated index+#+# DESCRIPTION+#+# The general approach is the same as in test 1, except we now set things up+# so that the cache has an outdated index.+#+# EXPECTED OUTCOME+#+# We should recover from the cache incoherence problem and still download the+# index incrementally (rather than downloading the entire index from scratch).+# See example log file for a succcessful run.+#+# ASSUMPTIONS+#+# Since this relies on incremental downloads, it must currently be tested+# against Apache rather than Hackage. Make sure to have+#+#   Header set Cache-Control "max-age=5, public, no-transform"+#+# in your .htaccess (and set AllowOverride: All for your domain, if necessary).+# As for test 1, you should also have a fresh instance of squid running.+##++set -x++BINDIR=../sandbox/7.8.3/bin+EXAMPLE_CLIENT=${BINDIR}/example-client+SECURITY_UTILITY=${BINDIR}/hackage-security+REPO=http://127.0.0.1/~e/local-repo+PROXY=http://localhost:3128+LOCAL_REPO=../unversioned/local-repo+KEYS=../unversioned/keys+LOCAL_CACHE=./tmp                        # NOTE: We will delete this directory++# Reset the repo+rm -rf ${LOCAL_REPO}/index+${SECURITY_UTILITY} -v bootstrap --repo ${LOCAL_REPO} --keys ${KEYS}++# Start with a fresh local cache, and do an update (directly, without squid) so+# that we have a local copy of the index that we can update incrementally later+unset HTTP_PROXY+unset http_proxy+rm -rf ${LOCAL_CACHE}+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} bootstrap 0+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} check++# Now start using squid+export HTTP_PROXY=${PROXY}+export http_proxy=${PROXY}++# Get the index from the server so that it's in squid's cache+curl -Lv ${REPO}/00-index.tar >/dev/null++# Add something to the index, and update snapshot/timestamp+# Sleep a bit first, so that the time on the extra file is definitely different+# to the time on the index+sleep 5+dd bs=1 count=16384 if=/dev/random of=${LOCAL_REPO}/index/extra-file+${SECURITY_UTILITY} -v update --repo ${LOCAL_REPO} --keys ${KEYS}++# Now do another update.+# The timestamp and snapshot will be out of sync with each other.+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} check
+ hackage-security/testscripts/test-outdated-timestamp.log view
@@ -0,0 +1,280 @@++ export HTTP_PROXY=http://localhost:3128++ HTTP_PROXY=http://localhost:3128++ export http_proxy=http://localhost:3128++ http_proxy=http://localhost:3128++ rm -rf ./tmp++ ../sandbox/7.8.3/bin/example-client --repo http://127.0.0.1:8080 --cache ./tmp bootstrap 0+# Selected mirror http://127.0.0.1:8080+# Downloading root+Sending:+GET http://127.0.0.1:8080/root.json HTTP/1.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Creating new connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=60
+Content-Length: 3323
+Content-MD5: 914e6bed90bde8179af0b657937ca1d9
+Content-Type: text/json
+Date: Mon, 13 Jul 2015 14:46:41 GMT
+ETag: "914e6bed90bde8179af0b657937ca1d9"
+Last-Modified: Thu, 11 Jun 2015 14:37:51 GMT
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++OK++ curl -Lv http://127.0.0.1:8080/timestamp.json+* Hostname was NOT found in DNS cache+  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current+                                 Dload  Upload   Total   Spent    Left  Speed+
  0     0    0     0    0     0      0      0 --:--:-- --:--:-- --:--:--     0*   Trying 127.0.0.1...+* Connected to localhost (127.0.0.1) port 3128 (#0)+> GET http://127.0.0.1:8080/timestamp.json HTTP/1.1
+> User-Agent: curl/7.37.1
+> Host: 127.0.0.1:8080
+> Accept: */*
+> Proxy-Connection: Keep-Alive
+> 
+< HTTP/1.1 200 OK
+< Cache-Control: public, no-transform, max-age=60
+< Content-Length: 420
+< Content-MD5: fea6f07b4caa591625bcf4a2f27fe9af
+< Content-Type: text/json
+< Date: Mon, 13 Jul 2015 14:46:41 GMT
+< ETag: "fea6f07b4caa591625bcf4a2f27fe9af"
+< Last-Modified: Mon, 13 Jul 2015 14:45:38 GMT
+* Server Happstack/7.4.4 is not blacklisted+< Server: Happstack/7.4.4
+< X-Cache: MISS from server.local
+< Via: 1.1 server.local (squid/3.5.6)
+< Connection: keep-alive
+< 
+{ [data not shown]+
100   420  100   420    0     0  52135      0 --:--:-- --:--:-- --:--:-- 60000+* Connection #0 to host localhost left intact++ killall -SIGHUP hackage-server++ sleep 5++ ../sandbox/7.8.3/bin/example-client --repo http://127.0.0.1:8080 --cache ./tmp check+# Selected mirror http://127.0.0.1:8080+# Downloading timestamp+Sending:+GET http://127.0.0.1:8080/timestamp.json HTTP/1.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Creating new connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=60
+Content-Length: 420
+Content-MD5: fea6f07b4caa591625bcf4a2f27fe9af
+Content-Type: text/json
+Date: Mon, 13 Jul 2015 14:46:41 GMT
+ETag: "fea6f07b4caa591625bcf4a2f27fe9af"
+Last-Modified: Mon, 13 Jul 2015 14:45:38 GMT
+Server: Happstack/7.4.4
+Age: 6
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading snapshot+Sending:+GET http://127.0.0.1:8080/snapshot.json HTTP/1.1
+Cache-Control: no-transform
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=60
+Content-Length: 791
+Content-MD5: 90a469a7bedd38afe12951dc774a555d
+Content-Type: text/json
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "90a469a7bedd38afe12951dc774a555d"
+Last-Modified: Mon, 13 Jul 2015 14:46:42 GMT
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Verification error: Invalid hash for <repo>/snapshot.json+# Downloading root+Sending:+GET http://127.0.0.1:8080/root.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Content-Length: 3323
+Content-MD5: 914e6bed90bde8179af0b657937ca1d9
+Content-Type: text/json
+Last-Modified: Thu, 11 Jun 2015 14:37:51 GMT
+Cache-Control: public, no-transform, max-age=60
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "914e6bed90bde8179af0b657937ca1d9"
+Server: Happstack/7.4.4
+Age: 1
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading timestamp+Sending:+GET http://127.0.0.1:8080/timestamp.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=60
+Content-Length: 420
+Content-MD5: 25aa54b986c278d7ec4a2d9514fe1316
+Content-Type: text/json
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "25aa54b986c278d7ec4a2d9514fe1316"
+Last-Modified: Mon, 13 Jul 2015 14:46:42 GMT
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading snapshot+Sending:+GET http://127.0.0.1:8080/snapshot.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Content-Length: 791
+Content-MD5: 90a469a7bedd38afe12951dc774a555d
+Content-Type: text/json
+Last-Modified: Mon, 13 Jul 2015 14:46:42 GMT
+Cache-Control: public, no-transform, max-age=60
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "90a469a7bedd38afe12951dc774a555d"
+Server: Happstack/7.4.4
+Age: 1
+X-Cache: HIT from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Downloading mirrors+Sending:+GET http://127.0.0.1:8080/mirrors.json HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=60
+Content-Length: 685
+Content-MD5: e98e8b013404cf085be353a055b723be
+Content-Type: text/json
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "e98e8b013404cf085be353a055b723be"
+Last-Modified: Thu, 11 Jun 2015 14:37:59 GMT
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++# Updating index failed (server does not provide incremental downloads)+# Downloading index+Sending:+GET http://127.0.0.1:8080/00-index.tar.gz HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 301 Moved Permanently 
+Content-Type: text/plain; charset=UTF-8
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+Location: /packages/index.tar.gz
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Transfer-Encoding: chunked
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+Content-Length: 0
+
++301 - redirect+Redirecting to http://127.0.0.1:8080/packages/index.tar.gz ...+Sending:+GET http://127.0.0.1:8080/packages/index.tar.gz HTTP/1.1
+Cache-Control: no-transform, max-age=0
+Content-Length: 0
+User-Agent: haskell-HTTP/4000.2.20
+Host: 127.0.0.1:8080
+
++proxy uri host: localhost, port: :3128+Recovering connection to localhost:3128+Received:+HTTP/1.1 200 OK 
+Cache-Control: public, no-transform, max-age=300
+Content-Length: 29
+Content-MD5: 31f6566d35ccd604be46ed5b1f813cdf
+Content-Type: application/x-gzip
+Date: Mon, 13 Jul 2015 14:46:46 GMT
+ETag: "31f6566d35ccd604be46ed5b1f813cdf"
+Last-Modified: Mon, 13 Jul 2015 08:18:42 GMT
+Server: Happstack/7.4.4
+X-Cache: MISS from server.local
+Via: 1.1 server.local (squid/3.5.6)
+Connection: keep-alive
+
++HasUpdates
+ hackage-security/testscripts/test-outdated-timestamp.sh view
@@ -0,0 +1,60 @@+#!/bin/bash++##+# Cache incoherence test 1: outdated timestamp+#+# DESCRIPTION+#+# We request the timestamp from the server through the proxy, so that it's in+# the proxy's cache (assuming a `max-age` header was set on the file). We then+# ask Hackage to resign, and do a check-for-updates using `example-client`.+# This will cause the proxy to return the now-outdated `timestamp` but a newer+# snapshot.+#+# NOTE: We refer to the cache maintained by the `hackage-security` library+# (through `example-client`) as the "local cache", and the cache maintained by+# squid as the "proxy cache".+#+# EXPECTED OUTCOME+#+# The client should detect this and try the request again, asking the+# cache to fetch the file stream. See the example log file.+#+# ASSUMPTIONS+#+# We assume Hackage is running on the same machine as the test script (so that+# we can send it SIGHUP), and that we have a fresh (nothing cached yet) instance+# of squid. There is an example configuration file for squid in this directory;+# start with+#+#     ~/homebrew/sbin/squid -f ./squid.conf -N -d 1+#+# (mutatis mutandis).+##++# Configuration+BINDIR=../sandbox/7.8.3/bin+EXAMPLE_CLIENT=${BINDIR}/example-client+REPO=http://127.0.0.1:8080+PROXY=http://localhost:3128+LOCAL_CACHE=./tmp                        # NOTE: We will delete this directory++set -x++# Enable the proxy+export HTTP_PROXY=${PROXY}+export http_proxy=${PROXY}++# Start with a fresh local cache (so that we definitely have updates)+rm -rf ${LOCAL_CACHE}+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} bootstrap 0++# Get the timestamp from the server (so that it's in proxy cache)+curl -Lv ${REPO}/timestamp.json >/dev/null++# Make the server resign the timestamp+killall -SIGHUP hackage-server+sleep 5++# Now do an update+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} check
+ hackage-security/testscripts/test-range-request.sh view
@@ -0,0 +1,13 @@+#!/bin/bash++BINDIR=../sandbox/7.8.3/bin+EXAMPLE_CLIENT=${BINDIR}/example-client+LOCAL_CACHE=../unversioned/cache/+#REPO=http://localhost:8080+REPO=http://localhost/~e/local-repo++rm -r ${LOCAL_CACHE}+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} bootstrap 0+dd if=/dev/zero of=${LOCAL_CACHE}/00-index.tar bs=1024 count=1+${EXAMPLE_CLIENT} --repo ${REPO} --cache ${LOCAL_CACHE} check+
hackport.cabal view
@@ -1,5 +1,5 @@ Name:           hackport-Version:        0.4.7+Version:        0.5 License:        GPL License-file:   LICENSE Author:         Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -20,40 +20,80 @@   ghc-prof-options: -caf-all -auto-all -rtsopts   Main-Is:    Main.hs   Default-Language: Haskell98-  Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install+  Hs-Source-Dirs:+      .,+      cabal,+      cabal/Cabal,+      cabal/cabal-install,+      hackage-security/hackage-security/src   Build-Depends:+    array,     base >= 2.0 && < 5,     deepseq >= 1.3,+    extensible-exceptions,     filepath,-    parsec,+    HTTP >= 4000.0.3,+    MissingH,     network >= 2.6, network-uri >= 2.6,+    parsec,     pretty,-    regex-compat,-    MissingH,     old-locale,-    HTTP >= 4000.0.3,-    zlib,+    regex-compat,+    split,     tar,-    xml >= 1.3.7,-    array,-    extensible-exceptions,     time,+    zlib,+    xml >= 1.3.7,     -- cabal depends     binary,     random,     stm,-    unix+    unix,+    -- cabal-install depends+    --  hackage-security depends+    base64-bytestring,+    cryptohash,+    ed25519,+    ghc-prim,+    hashable,+    mtl,+    template-haskell,+    transformers -  -- extensions due to hackport-  other-extensions:+  default-extensions:+    -- hackage-security+    DefaultSignatures,     DeriveDataTypeable,-    PatternGuards--  -- extensions due to bundled cabal-install+    EmptyDataDecls,+    ExistentialQuantification,+    FlexibleContexts,+    FlexibleInstances,+    GADTs,+    GeneralizedNewtypeDeriving,+    KindSignatures,+    MultiParamTypeClasses,+    PatternGuards,+    RankNTypes,+    RecordWildCards,+    ScopedTypeVariables,+    StandaloneDeriving,+    TypeFamilies,+    TypeOperators,+    ViewPatterns   other-extensions:+    DeriveDataTypeable,+    PatternGuards,+    -- extensions due to bundled cabal-install     CPP,     ForeignFunctionInterface,-    PatternGuards+    --  hackage-security extensions+    DefaultSignatures,+    GeneralizedNewtypeDeriving,+    GADTs,+    KindSignatures,+    RankNTypes,+    RecordWildCards,+    TypeOperators    Build-Depends:     base >= 3 && < 5,@@ -66,10 +106,7 @@   other-modules:     AnsiColor     Cabal2Ebuild-    CacheFile-    Diff     Error-    Hackage     Main     Overlays     Paths_hackport@@ -87,40 +124,6 @@     Merge     Util --Executable    hackport-guess-ghc-version-  ghc-options: -Wall-  Main-Is:    Main-GuessGHC.hs-  Default-Language: Haskell98-  Buildable:    False-  -- this was used as a test while developing the-  -- ghc-guessfeature. now we can disable building-  Build-Depends:-    base >= 2.0 && < 5,-    filepath,-    parsec,-    network >= 2.6, network-uri >= 2.6,-    pretty,-    regex-compat,-    HTTP >= 4000.0.3,-    zlib,-    tar,-    array,-  -- array is inherited from cabal-install -  -- tar >= 0.3.0.0 && < 0.4-    extensible-exceptions--  Build-Depends:-    base >= 3 && < 5,-    directory,-    containers,-    process,-    old-time,-    bytestring--  other-modules:-    Portage.GHCCore- Test-Suite test-resolve-category   ghc-options: -Wall   Type:                 exitcode-stdio-1.0@@ -138,6 +141,7 @@                         HUnit,                         pretty,                         process,+                        split,                         time,                         unix,                         xml