cabal-install-bundle 0.14.0 → 0.16.0.2
raw patch · 44 files changed
+1081/−444 lines, 44 filesdep ~Cabal
Dependency ranges changed: Cabal
Files
- Control/Monad/Error/Class.hs +3/−1
- Distribution/Client/BuildReports/Upload.hs +2/−2
- Distribution/Client/Config.hs +4/−1
- Distribution/Client/Configure.hs +7/−4
- Distribution/Client/Dependency/Modular/Assignment.hs +8/−0
- Distribution/Client/Dependency/Modular/Builder.hs +3/−3
- Distribution/Client/Dependency/Modular/Dependency.hs +2/−2
- Distribution/Client/Dependency/Modular/Explore.hs +12/−12
- Distribution/Client/Dependency/Modular/Flag.hs +5/−3
- Distribution/Client/Dependency/Modular/Index.hs +1/−1
- Distribution/Client/Dependency/Modular/IndexConversion.hs +19/−20
- Distribution/Client/Dependency/Modular/Log.hs +20/−8
- Distribution/Client/Dependency/Modular/Message.hs +1/−0
- Distribution/Client/Dependency/Modular/Preference.hs +26/−9
- Distribution/Client/Dependency/Modular/Solver.hs +4/−2
- Distribution/Client/Dependency/Modular/Tree.hs +57/−56
- Distribution/Client/Dependency/Modular/Validate.hs +4/−4
- Distribution/Client/Dependency/TopDown.hs +4/−4
- Distribution/Client/Haddock.hs +8/−9
- Distribution/Client/IndexUtils.hs +38/−35
- Distribution/Client/Init.hs +5/−2
- Distribution/Client/Init/Licenses.hs +206/−0
- Distribution/Client/Install.hs +232/−88
- Distribution/Client/InstallPlan.hs +42/−16
- Distribution/Client/InstallSymlink.hs +5/−4
- Distribution/Client/Setup.hs +31/−9
- Distribution/Client/SetupWrapper.hs +121/−52
- Distribution/Client/Tar.hs +3/−11
- Distribution/Client/Targets.hs +8/−6
- Distribution/Client/Types.hs +9/−3
- Distribution/Client/Unpack.hs +24/−9
- Distribution/Client/Utils.hs +15/−1
- Distribution/Client/World.hs +2/−1
- Main.hs +4/−18
- Network/Browser.hs +4/−2
- Network/HTTP.hs +45/−12
- Network/HTTP/Base.hs +4/−3
- Network/HTTP/HandleStream.hs +13/−7
- Network/HTTP/Proxy.hs +5/−2
- Network/HTTP/Stream.hs +13/−7
- Network/StreamSocket.hs +2/−2
- Network/TCP.hs +11/−10
- cabal-install-bundle.cabal +3/−3
- cbits/getnumcores.c +46/−0
Control/Monad/Error/Class.hs view
@@ -5,6 +5,7 @@ Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001, (c) Jeff Newbern 2003-2006, (c) Andriy Palamarchuk 2006+ (c) Edward Kmett 2012 License : BSD-style (see the file LICENSE) Maintainer : libraries@haskell.org@@ -52,10 +53,11 @@ import Control.Monad.Trans.Writer.Strict as StrictWriter import Control.Monad.Trans.Class (lift)-import Control.Exception (IOException)+import Control.Exception (IOException, catch, ioError) import Control.Monad import Control.Monad.Instances () import Data.Monoid+import Prelude (Either(..), (.), IO) {- | The strategy of combining computations that can throw exceptions
Distribution/Client/BuildReports/Upload.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards #-} -- This is a quick hack for uploading build reports to Hackage. module Distribution.Client.BuildReports.Upload@@ -61,7 +61,7 @@ -> BrowserAction (HandleStream BuildLog) () putBuildLog reportId buildLog = do --FIXME: do something if the request fails- (_, response) <- request Request {+ (_, _response) <- request Request { rqURI = reportId{uriPath = uriPath reportId </> "log"}, rqMethod = PUT, rqHeaders = [Header HdrContentType ("text/plain"),
Distribution/Client/Config.hs view
@@ -93,6 +93,8 @@ ( getEnvironment ) import System.IO.Error ( isDoesNotExistError )+import Distribution.Compat.Exception+ ( catchIO ) -- -- * Configuration saved in the config file@@ -199,6 +201,7 @@ savedInstallFlags = mempty { installSummaryFile = [toPathTemplate (logsDir </> "build.log")], installBuildReports= toFlag AnonymousReports+ --installNumJobs = toFlag (Just numberOfProcessors) } } @@ -291,7 +294,7 @@ fmap (Just . parseConfig initial) (readFile file) where- handleNotExists action = catch action $ \ioe ->+ handleNotExists action = catchIO action $ \ioe -> if isDoesNotExistError ioe then return Nothing else ioError ioe
Distribution/Client/Configure.hs view
@@ -82,7 +82,7 @@ configureCommand (const configFlags) extraArgs Right installPlan -> case InstallPlan.ready installPlan of- [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] ->+ [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] -> configurePackage verbosity (InstallPlan.planPlatform installPlan) (InstallPlan.planCompiler installPlan)@@ -104,7 +104,9 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useWorkingDir = Nothing,+ forceExternalSetupMethod = False,+ setupCacheLock = Nothing } where -- Hack: we typically want to allow the UserPackageDB for finding the@@ -136,7 +138,8 @@ localPkg = SourcePackage { packageInfoId = packageId pkg, Source.packageDescription = pkg,- packageSource = LocalUnpackedPackage "."+ packageSource = LocalUnpackedPackage ".",+ packageDescrOverride = Nothing } testsEnabled = fromFlagOrDefault False $ configTests configFlags@@ -192,7 +195,7 @@ -> [String] -> IO () configurePackage verbosity platform comp scriptOptions configFlags- (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs =+ (ConfiguredPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs = setupWrapper verbosity scriptOptions (Just pkg) configureCommand configureFlags extraArgs
Distribution/Client/Dependency/Modular/Assignment.hs view
@@ -41,6 +41,14 @@ -- | Extend a package preassignment. --+-- Takes the variable that causes the new constraints, a current preassignment+-- and a set of new dependency constraints.+--+-- We're trying to extend the preassignment with each dependency one by one.+-- Each dependency is for a particular variable. We check if we already have+-- constraints for that variable in the current preassignment. If so, we're+-- trying to merge the constraints.+-- -- 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
Distribution/Client/Dependency/Modular/Builder.hs view
@@ -63,7 +63,7 @@ -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagDefaults ->+scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s where@@ -104,8 +104,8 @@ -- that is indicated by the flag default. -- -- TODO: Should we include the flag default in the tree?- go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) =- FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b+ go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =+ FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) where
Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -95,8 +95,8 @@ -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. data FlaggedDep qpn =- Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)- | Stanza (SN qpn) (TrueFlaggedDeps qpn)+ Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+ | Stanza (SN qpn) (TrueFlaggedDeps qpn) | Simple (Dep qpn) deriving (Eq, Show)
Distribution/Client/Dependency/Modular/Explore.hs view
@@ -24,16 +24,16 @@ 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'))+ 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 ts) = (c, FChoice qfn c b (P.fromList ts'))+ 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'))+ 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'))+ 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@@ -77,22 +77,22 @@ where go (FailF _ _) _ = A.empty go (DoneF rdm) a = pure (a, rdm)- go (PChoiceF qpn _ ts) (A pa fa sa) =+ go (PChoiceF qpn _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice ts- go (FChoiceF qfn _ _ ts) (A pa fa sa) =+ 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) =+ 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 =+ 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 @@ -102,28 +102,28 @@ where go (FailF c fr) _ = failWith (Failure c fr) go (DoneF rdm) a = succeedWith Success (a, rdm)- go (PChoiceF qpn c ts) (A pa fa sa) =+ go (PChoiceF qpn c ts) (A pa fa sa) = backjumpInfo c $ asum $ -- try children in order, P.mapWithKey -- when descending ... (\ k r -> tryWith (TryP (PI qpn k)) $ -- 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) =+ go (FChoiceF qfn c _ _ ts) (A pa fa sa) = backjumpInfo c $ asum $ -- 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) =+ go (SChoiceF qsn c _ ts) (A pa fa sa) = backjumpInfo c $ asum $ -- 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 =+ 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
Distribution/Client/Dependency/Modular/Flag.hs view
@@ -25,11 +25,13 @@ unFlag :: Flag -> String unFlag (FlagName fn) = fn --- | Flag default. Just a bool.-type FDefault = Bool+-- | Flag info. Default value, and whether the flag is manual.+-- Manual flags can only be set explicitly.+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }+ deriving (Eq, Ord, Show) -- | Flag defaults.-type FlagDefaults = Map Flag FDefault+type FlagInfo = Map Flag FInfo -- | Qualified flag name. type QFN = FN QPN
Distribution/Client/Dependency/Modular/Index.hs view
@@ -20,7 +20,7 @@ -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps PN) FlagDefaults Encaps (Maybe FailReason)+data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason) deriving (Show) -- | Encapsulations. A list of package names.
Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -12,7 +12,6 @@ import Distribution.Package -- from Cabal import Distribution.PackageDescription as PD -- from Cabal import qualified Distribution.Simple.PackageIndex as SI-import Distribution.Simple.Utils (equating) import Distribution.System import Distribution.Client.Dependency.Modular.Dependency as D@@ -25,9 +24,9 @@ -- | Convert both the installed package index and the source package -- index into one uniform solver index. ----- We use 'allPackagesByName' for the installed package index because--- that returns us several instances of the same package and version--- in order of preference. This allows us in principle to "shadow"+-- We use 'allPackagesBySourcePackageId' for the installed package index+-- because that returns us several instances of the same package and version+-- in order of preference. This allows us in principle to \"shadow\" -- packages if there are several installed packages of the same version. -- There are currently some shortcomings in both GHC and Cabal in -- resolving these situations. However, the right thing to do is to@@ -41,14 +40,14 @@ -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)]-convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx- where- -- group installed packages by version- versioned = L.map (groupBy (equating packageVersion))+convIPI' sip idx = -- apply shadowing whenever there are multple installed packages with -- the same version- combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn,- (g, p) <- zip (id : repeat shadow) pbv ]+ [ maybeShadow (convIP idx pkg)+ | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx+ , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]+ where+ -- shadowing is recorded in the package info shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) shadow x = x@@ -93,7 +92,7 @@ -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)-convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) =+convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo in (pn, i, convGPD os arch cid (PI pn i) gpd) @@ -110,29 +109,29 @@ convGPD os arch cid pi (GenericPackageDescription _ flags libs exes tests benchs) = let- fds = flagDefaults flags+ fds = flagInfo flags in PInfo (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ (prefix (Stanza (SN pi TestStanzas))- (concatMap (convCondTree os arch cid pi fds (const True) . snd) tests)) +++ (L.map (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ (prefix (Stanza (SN pi BenchStanzas))- (concatMap (convCondTree os arch cid pi fds (const True) . snd) benchs)))+ (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs))) fds [] -- TODO: add encaps Nothing -prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn+prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ [] = []-prefix f fds = [f fds]+prefix f fds = [f (concat fds)] -- | Convert flag information.-flagDefaults :: [PD.Flag] -> FlagDefaults-flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b))+flagInfo :: [PD.Flag] -> FlagInfo+flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m)) -- | Convert condition trees to flagged dependencies.-convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults ->+convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active CondTree ConfVar [Dependency] a -> FlaggedDeps PN convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches)@@ -149,7 +148,7 @@ -- special flags and subsequently simplify to a tree that only depends on -- simple flag choices. convBranch :: OS -> Arch -> CompilerId ->- PI PN -> FlagDefaults ->+ PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active (Condition ConfVar, CondTree ConfVar [Dependency] a,
Distribution/Client/Dependency/Modular/Log.hs view
@@ -34,18 +34,21 @@ (ms, s) = runLog l (es, e) = proc 0 ms -- catch first error (always) (ns, t) = case mbj of- Nothing -> (ms, Nothing)- Just n -> proc n ms+ Nothing -> (ms, Nothing)+ Just n -> proc n ms -- prefer first error over later error r = case t of Nothing -> case s of Nothing -> e Just _ -> Nothing Just _ -> e- in go es -- trace for first error+ in go es es -- trace for first error (showMessages (const True) True ns) -- shortened run r s 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 : _))@@ -54,15 +57,24 @@ 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 thirs argument is the full log, the fifth and six error conditions.+ -- -- 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 (x : xs) r s = Step x (go ms xs r s)- go ms [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++- unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))- go _ [] _ (Just s) = Done s- go _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen+ go ms (_ : ns) (x : xs) r s = Step x (go ms ns xs r s)+ go ms [] (x : xs) r s = Step x (go ms [] xs r s)+ go ms _ [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" +++ unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))+ go _ _ [] _ (Just s) = Done s+ go _ _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen logToProgress' :: Log Message a -> Progress String String a logToProgress' l = let
Distribution/Client/Dependency/Modular/Message.hs view
@@ -87,6 +87,7 @@ showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)" showFR _ GlobalConstraintSource = " (global constraint requires source instance)" showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)"+showFR _ ManualFlag = " (manual flag can only be changed explicitly)" showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")" showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" -- The following are internal failures. They should not occur. In the
Distribution/Client/Dependency/Modular/Preference.hs view
@@ -108,26 +108,43 @@ enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons enforcePackageConstraints pcs = trav go where- go (PChoiceF qpn@(Q _ pn) gr ts) =+ go (PChoiceF qpn@(Q _ pn) gr ts) = let c = toConflictSet (Goal (P qpn) gr) -- compose the transformation functions for each of the relevant constraint g = \ i -> foldl (\ h pc -> h . processPackageConstraintP 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 ts) =+ in PChoiceF qpn gr (P.mapWithKey g ts)+ go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = let c = toConflictSet (Goal (F qfn) gr) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id (M.findWithDefault [] pn pcs)- in FChoiceF qfn gr tr (P.mapWithKey g ts)- go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) =+ in FChoiceF qfn gr tr m (P.mapWithKey g ts)+ go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = let c = toConflictSet (Goal (S qsn) gr) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id (M.findWithDefault [] pn pcs)- in SChoiceF qsn gr tr (P.mapWithKey g ts)+ in SChoiceF qsn gr tr (P.mapWithKey g ts) go x = x +-- | Transformation that tries to enforce manual flags. Manual flags+-- can only be re-set explicitly by the user. This transformation should+-- be run after user preferences have been enforced. For manual flags,+-- it disables all but the first non-disabled choice.+enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons+enforceManualFlags = trav go+ where+ go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $+ let c = toConflictSet (Goal (F qfn) gr)+ in case span isDisabled (P.toList ts) of+ (_ , []) -> P.fromList []+ (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)+ where+ isDisabled (_, Fail _ _) = True+ isDisabled _ = False+ go x = x+ -- | Prefer installed packages over non-installed packages, generally. -- All installed packages or non-installed packages are treated as -- equivalent.@@ -232,9 +249,9 @@ go x = x defer :: Tree a -> Tree a -> Ordering- defer (FChoice _ _ True _) _ = GT- defer _ (FChoice _ _ True _) = LT- defer _ _ = EQ+ defer (FChoice _ _ True _ _) _ = GT+ defer _ (FChoice _ _ True _ _) = LT+ defer _ _ = EQ -- | Variant of 'preferEasyGoalChoices'. --
Distribution/Client/Dependency/Modular/Solver.hs view
@@ -39,11 +39,13 @@ buildPhase where explorePhase = exploreTreeLog . backjump- heuristicsPhase = if preferEasyGoalChoices sc+ heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)+ if preferEasyGoalChoices sc then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices else P.preferBaseGoalChoice preferencesPhase = P.preferPackagePreferences userPrefs- validationPhase = P.enforcePackageConstraints userConstraints .+ validationPhase = P.enforceManualFlags . -- can only be done after user constraints+ P.enforcePackageConstraints userConstraints . validateTree idx prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . -- packages that can never be "upgraded":
Distribution/Client/Dependency/Modular/Tree.hs view
@@ -14,10 +14,10 @@ -- | Type of the search tree. Inlining the choice nodes for now. data Tree a =- PChoice QPN a (PSQ I (Tree a))- | FChoice QFN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial- | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial- | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty+ PChoice QPN a (PSQ I (Tree a))+ | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual+ | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial+ | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty | Done RevDepMap | Fail (ConflictSet QPN) FailReason deriving (Eq, Show)@@ -26,12 +26,12 @@ -- dependencies introduced by this node. instance Functor Tree where- fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)- fmap f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs)- fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)- fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)- fmap _f (Done rdm ) = Done rdm- fmap _f (Fail cs fr ) = Fail cs fr+ fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs)+ fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs)+ fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs)+ fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs)+ fmap _f (Done rdm ) = Done rdm+ fmap _f (Fail cs fr ) = Fail cs fr data FailReason = InconsistentInitialConstraints | Conflicting [Dep QPN]@@ -43,6 +43,7 @@ | GlobalConstraintInstalled | GlobalConstraintSource | GlobalConstraintFlag+ | ManualFlag | BuildFailureNotInIndex PN | MalformedFlagChoice QFN | MalformedStanzaChoice QSN@@ -52,52 +53,52 @@ -- | Functor for the tree type. data TreeF a b =- PChoiceF QPN a (PSQ I b)- | FChoiceF QFN a Bool (PSQ Bool b)- | SChoiceF QSN a Bool (PSQ Bool b)- | GoalChoiceF (PSQ OpenGoal b)+ PChoiceF QPN a (PSQ I b)+ | FChoiceF QFN a Bool Bool (PSQ Bool b)+ | SChoiceF QSN a Bool (PSQ Bool b)+ | GoalChoiceF (PSQ OpenGoal b) | DoneF RevDepMap | FailF (ConflictSet QPN) FailReason out :: Tree a -> TreeF a (Tree a)-out (PChoice p i ts) = PChoiceF p i ts-out (FChoice p i b ts) = FChoiceF p i b ts-out (SChoice p i b ts) = SChoiceF p i b ts-out (GoalChoice ts) = GoalChoiceF ts-out (Done x ) = DoneF x-out (Fail c x ) = FailF c x+out (PChoice p i ts) = PChoiceF p i ts+out (FChoice p i b m ts) = FChoiceF p i b m ts+out (SChoice p i b ts) = SChoiceF p i b ts+out (GoalChoice ts) = GoalChoiceF ts+out (Done x ) = DoneF x+out (Fail c x ) = FailF c x inn :: TreeF a (Tree a) -> Tree a-inn (PChoiceF p i ts) = PChoice p i ts-inn (FChoiceF p i b ts) = FChoice p i b ts-inn (SChoiceF p i b ts) = SChoice p i b ts-inn (GoalChoiceF ts) = GoalChoice ts-inn (DoneF x ) = Done x-inn (FailF c x ) = Fail c x+inn (PChoiceF p i ts) = PChoice p i ts+inn (FChoiceF p i b m ts) = FChoice p i b m ts+inn (SChoiceF p i b ts) = SChoice p i b ts+inn (GoalChoiceF ts) = GoalChoice ts+inn (DoneF x ) = Done x+inn (FailF c x ) = Fail c x instance Functor (TreeF a) where- fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)- fmap f (FChoiceF p i b ts) = FChoiceF p i b (fmap f ts)- fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)- fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)- fmap _ (DoneF x ) = DoneF x- fmap _ (FailF c x ) = FailF c x+ fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts)+ fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts)+ fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts)+ fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts)+ fmap _ (DoneF x ) = DoneF x+ fmap _ (FailF c x ) = FailF c x instance Foldable (TreeF a) where- foldr op e (PChoiceF _ _ ts) = foldr op e ts- foldr op e (FChoiceF _ _ _ ts) = foldr op e ts- foldr op e (SChoiceF _ _ _ ts) = foldr op e ts- foldr op e (GoalChoiceF ts) = foldr op e ts- foldr _ e (DoneF _ ) = e- foldr _ e (FailF _ _ ) = e+ foldr op e (PChoiceF _ _ ts) = foldr op e ts+ foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts+ foldr op e (SChoiceF _ _ _ ts) = foldr op e ts+ foldr op e (GoalChoiceF ts) = foldr op e ts+ foldr _ e (DoneF _ ) = e+ foldr _ e (FailF _ _ ) = e instance Traversable (TreeF a) where- traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts- traverse f (FChoiceF p i b ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts- traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts- traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts- traverse _ (DoneF x ) = DoneF <$> pure x- traverse _ (FailF c x ) = FailF <$> pure c <*> pure x+ traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts+ traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts+ traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts+ traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts+ traverse _ (DoneF x ) = DoneF <$> pure x+ traverse _ (FailF c x ) = FailF <$> pure c <*> pure x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree a -> Bool@@ -107,22 +108,22 @@ -- | Determines how many active choices are available in a node. Note that we -- count goal choices as having one choice, always. choices :: Tree a -> Int-choices (PChoice _ _ ts) = P.length (P.filter active ts)-choices (FChoice _ _ _ ts) = P.length (P.filter active ts)-choices (SChoice _ _ _ ts) = P.length (P.filter active ts)-choices (GoalChoice _ ) = 1-choices (Done _ ) = 1-choices (Fail _ _ ) = 0+choices (PChoice _ _ ts) = P.length (P.filter active ts)+choices (FChoice _ _ _ _ ts) = P.length (P.filter active ts)+choices (SChoice _ _ _ ts) = P.length (P.filter active ts)+choices (GoalChoice _ ) = 1+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+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 -- | Catamorphism on trees. cata :: (TreeF a b -> b) -> Tree a -> b
Distribution/Client/Dependency/Modular/Validate.hs view
@@ -85,8 +85,8 @@ where go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) - go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)- go (FChoiceF qfn (gr, _sc) b ts) =+ go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)+ go (FChoiceF qfn (gr, _sc) b m ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby@@ -98,8 +98,8 @@ Just t -> goF qfn gr rb t Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches- FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts)- go (SChoiceF qsn (gr, _sc) b ts) =+ FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts)+ go (SChoiceF qsn (gr, _sc) b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment
Distribution/Client/Dependency/TopDown.hs view
@@ -368,7 +368,7 @@ [ (dep, Constraints.conflicting cs dep) | dep <- missing ] - configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) =+ configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) = finalizePackageDescription flags (dependencySatisfiable cs) platform comp [] (enableStanzas stanzas pkg) dependencySatisfiable cs =@@ -397,7 +397,7 @@ InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) (configure apkg) where- configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) =+ configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) = case finalizePackageDescription flags dependencySatisfiable platform comp [] (enableStanzas stanzas p) of Left missing -> Left missing@@ -481,7 +481,7 @@ ++ [ ((), packageName pkg, nub deps) | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex , let deps = [ depName- | SourcePackage _ pkg' _ <- pkgs+ | SourcePackage _ pkg' _ _ <- pkgs , Dependency depName _ <- buildDepends (flattenPackageDescription pkg') ] ] @@ -517,7 +517,7 @@ | pkg <- moreInstalled , dep <- depends pkg ] ++ [ name- | SourcePackage _ pkg _ <- moreSource+ | SourcePackage _ pkg _ _ <- moreSource , Dependency name _ <- buildDepends (flattenPackageDescription pkg) ] installedPkgIndex'' = foldl' (flip PackageIndex.insert)
Distribution/Client/Haddock.hs view
@@ -22,14 +22,15 @@ import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile) import System.FilePath ((</>), splitFileName)-import Distribution.Package (Package(..))+import Distribution.Package+ ( Package(..), packageVersion ) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration , rawSystemProgram, requireProgramVersion) import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Text (display)-import Distribution.Simple.PackageIndex (PackageIndex, allPackages,- allPackagesByName, fromList)+import Distribution.Simple.PackageIndex+ ( PackageIndex, allPackagesByName ) import Distribution.Simple.Utils ( comparing, intercalate, debug , installDirectoryContents, withTempDirectory )@@ -64,12 +65,10 @@ where (destDir,destFile) = splitFileName index- pkgs' = map (maximumBy $ comparing packageId)- . allPackagesByName- . fromList- . filter exposed- . allPackages- $ pkgs+ pkgs' = [ maximumBy (comparing packageVersion) pkgvers'+ | (_pname, pkgvers) <- allPackagesByName pkgs+ , let pkgvers' = filter exposed pkgvers+ , not (null pkgvers') ] haddockPackagePaths :: [InstalledPackageInfo] -> IO ([(FilePath, FilePath)], Maybe String)
Distribution/Client/IndexUtils.hs view
@@ -51,11 +51,11 @@ import Distribution.Verbosity ( Verbosity, lessVerbose ) import Distribution.Simple.Utils- ( die, warn, info, fromUTF8, equating )+ ( die, warn, info, fromUTF8 ) import Data.Char (isAlphaNum) import Data.Maybe (catMaybes, fromMaybe)-import Data.List (isPrefixOf, groupBy)+import Data.List (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map import Control.Monad (MonadPlus(mplus), when, unless, liftM)@@ -71,10 +71,10 @@ import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError)+import Distribution.Compat.Exception (catchIO) import System.Directory ( getModificationTime, doesFileExist )-import System.Time- ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )+import Distribution.Compat.Time getInstalledPackages :: Verbosity -> Compiler@@ -88,15 +88,14 @@ convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage convert index' = PackageIndex.fromList- -- There can be multiple installed instances of each package version,- -- like when the same package is installed in the global & user dbs.- -- InstalledPackageIndex.allPackagesByName gives us the installed- -- packages with the most preferred instances first, so by picking the- -- first we should get the user one. This is almost but not quite the- -- same as what ghc does.- [ InstalledPackage ipkg (sourceDeps index' ipkg)- | ipkgs <- InstalledPackageIndex.allPackagesByName index'- , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]+ -- There can be multiple installed instances of each package version,+ -- like when the same package is installed in the global & user dbs.+ -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the+ -- installed packages with the most preferred instances first, so by+ -- picking the first we should get the user one. This is almost but not+ -- quite the same as what ghc does.+ [ InstalledPackage ipkg (sourceDeps index' ipkg)+ | (_,ipkg:_) <- InstalledPackageIndex.allPackagesBySourcePackageId index' ] where -- The InstalledPackageInfo only lists dependencies by the -- InstalledPackageId, which means we do not directly know the corresponding@@ -170,14 +169,15 @@ readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile where- mkAvailablePackage pkgid pkg =+ mkAvailablePackage pkgid pkgtxt pkg = SourcePackage { packageInfoId = pkgid, packageDescription = pkg,- packageSource = RepoTarballPackage repo pkgid Nothing+ packageSource = RepoTarballPackage repo pkgid Nothing,+ packageDescrOverride = Just pkgtxt } - handleNotFound action = catch action $ \e -> if isDoesNotExistError e+ handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e then do case repoKind repo of Left remoteRepo -> warn verbosity $@@ -191,13 +191,11 @@ isOldThreshold = 15 --days warnIfIndexIsOld indexFile = do- indexTime <- getModificationTime indexFile- currentTime <- getClockTime- let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)- when (tdDay diff >= isOldThreshold) $ case repoKind repo of+ dt <- getFileAge indexFile+ when (dt >= isOldThreshold) $ case repoKind repo of Left remoteRepo -> warn verbosity $ "The package list for '" ++ remoteRepoName remoteRepo- ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun "+ ++ "' is " ++ show dt ++ " days old.\nRun " ++ "'cabal update' to get the latest list of available packages." Right _localRepo -> return () @@ -338,11 +336,12 @@ writeFile cacheFile (showIndexCache cache) where mkCache pkgs prefs =- [ CachePrefrence pref | pref <- prefs ]+ [ CachePreference pref | pref <- prefs ] ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ] readPackageIndexCacheFile :: Package pkg- => (PackageId -> GenericPackageDescription -> pkg)+ => (PackageId -> ByteString+ -> GenericPackageDescription -> pkg) -> FilePath -> FilePath -> IO (PackageIndex pkg, [Dependency])@@ -353,7 +352,8 @@ packageIndexFromCache :: Package pkg- => (PackageId -> GenericPackageDescription -> pkg)+ => (PackageId -> ByteString+ -> GenericPackageDescription -> pkg) -> Handle -> [IndexCacheEntry] -> IO (PackageIndex pkg, [Dependency])@@ -371,20 +371,22 @@ -- The magic here is that we use lazy IO to read the .cabal file -- from the index tarball if it turns out that we need it. -- Most of the time we only need the package id.- pkg <- unsafeInterleaveIO $ do- getPackageDescription blockno- let srcpkg = mkPkg pkgid pkg+ ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do+ pkgtxt <- getEntryContent blockno+ pkg <- readPackageDescription pkgtxt+ return (pkg, pkgtxt)++ let srcpkg = mkPkg pkgid pkgtxt pkg accum (srcpkg:srcpkgs) prefs entries - accum srcpkgs prefs (CachePrefrence pref : entries) =+ accum srcpkgs prefs (CachePreference pref : entries) = accum srcpkgs (pref:prefs) entries - getPackageDescription blockno = do+ getEntryContent blockno = do hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512)) header <- BS.hGet hnd 512 size <- getEntrySize header- content <- BS.hGet hnd (fromIntegral size)- readPackageDescription content+ BS.hGet hnd (fromIntegral size) getEntrySize header = case Tar.read header of@@ -413,7 +415,7 @@ type BlockNo = Int data IndexCacheEntry = CachePackageId PackageId BlockNo- | CachePrefrence Dependency+ | CachePreference Dependency deriving (Eq, Show) readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry@@ -421,12 +423,13 @@ case BSS.words line of [key, pkgnamestr, pkgverstr, sep, blocknostr] | key == packageKey && sep == blocknoKey ->- case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of+ case (parseName pkgnamestr, parseVer pkgverstr [],+ parseBlockNo blocknostr) of (Just pkgname, Just pkgver, Just blockno) -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) _ -> Nothing (key: remainder) | key == preferredVersionKey ->- fmap CachePrefrence (simpleParse (BSS.unpack (BSS.unwords remainder)))+ fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder))) _ -> Nothing where packageKey = BSS.pack "pkg:"@@ -456,7 +459,7 @@ CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid) ++ " " ++ display (packageVersion pkgid) ++ " b# " ++ show b- CachePrefrence dep -> "pref-ver: " ++ display dep+ CachePreference dep -> "pref-ver: " ++ display dep readIndexCache :: BSS.ByteString -> [IndexCacheEntry] readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines
Distribution/Client/Init.hs view
@@ -67,7 +67,7 @@ import Distribution.Client.Init.Types ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses- ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )+ ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 ) import Distribution.Client.Init.Heuristics ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) @@ -178,7 +178,7 @@ return $ flags { license = maybeToFlag lic } where listedLicenses =- knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]+ knownLicenses \\ [GPL Nothing, LGPL Nothing, Apache Nothing, OtherLicense] -- | The author's name and email. Prompt, or try to guess from an existing -- darcs repo.@@ -494,6 +494,9 @@ Flag (LGPL (Just (Version {versionBranch = [3]}))) -> Just lgpl3++ Flag (Apache (Just (Version {versionBranch = [2, 0]})))+ -> Just apache20 _ -> Nothing
Distribution/Client/Init/Licenses.hs view
@@ -5,6 +5,7 @@ , gplv3 , lgpl2 , lgpl3+ , apache20 ) where @@ -1720,3 +1721,208 @@ , "Library." ] +apache20 :: License+apache20 = unlines+ [ ""+ , " Apache License"+ , " Version 2.0, January 2004"+ , " http://www.apache.org/licenses/"+ , ""+ , " TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION"+ , ""+ , " 1. Definitions."+ , ""+ , " \"License\" shall mean the terms and conditions for use, reproduction,"+ , " and distribution as defined by Sections 1 through 9 of this document."+ , ""+ , " \"Licensor\" shall mean the copyright owner or entity authorized by"+ , " the copyright owner that is granting the License."+ , ""+ , " \"Legal Entity\" shall mean the union of the acting entity and all"+ , " other entities that control, are controlled by, or are under common"+ , " control with that entity. For the purposes of this definition,"+ , " \"control\" means (i) the power, direct or indirect, to cause the"+ , " direction or management of such entity, whether by contract or"+ , " otherwise, or (ii) ownership of fifty percent (50%) or more of the"+ , " outstanding shares, or (iii) beneficial ownership of such entity."+ , ""+ , " \"You\" (or \"Your\") shall mean an individual or Legal Entity"+ , " exercising permissions granted by this License."+ , ""+ , " \"Source\" form shall mean the preferred form for making modifications,"+ , " including but not limited to software source code, documentation"+ , " source, and configuration files."+ , ""+ , " \"Object\" form shall mean any form resulting from mechanical"+ , " transformation or translation of a Source form, including but"+ , " not limited to compiled object code, generated documentation,"+ , " and conversions to other media types."+ , ""+ , " \"Work\" shall mean the work of authorship, whether in Source or"+ , " Object form, made available under the License, as indicated by a"+ , " copyright notice that is included in or attached to the work"+ , " (an example is provided in the Appendix below)."+ , ""+ , " \"Derivative Works\" shall mean any work, whether in Source or Object"+ , " form, that is based on (or derived from) the Work and for which the"+ , " editorial revisions, annotations, elaborations, or other modifications"+ , " represent, as a whole, an original work of authorship. For the purposes"+ , " of this License, Derivative Works shall not include works that remain"+ , " separable from, or merely link (or bind by name) to the interfaces of,"+ , " the Work and Derivative Works thereof."+ , ""+ , " \"Contribution\" shall mean any work of authorship, including"+ , " the original version of the Work and any modifications or additions"+ , " to that Work or Derivative Works thereof, that is intentionally"+ , " submitted to Licensor for inclusion in the Work by the copyright owner"+ , " or by an individual or Legal Entity authorized to submit on behalf of"+ , " the copyright owner. For the purposes of this definition, \"submitted\""+ , " means any form of electronic, verbal, or written communication sent"+ , " to the Licensor or its representatives, including but not limited to"+ , " communication on electronic mailing lists, source code control systems,"+ , " and issue tracking systems that are managed by, or on behalf of, the"+ , " Licensor for the purpose of discussing and improving the Work, but"+ , " excluding communication that is conspicuously marked or otherwise"+ , " designated in writing by the copyright owner as \"Not a Contribution.\""+ , ""+ , " \"Contributor\" shall mean Licensor and any individual or Legal Entity"+ , " on behalf of whom a Contribution has been received by Licensor and"+ , " subsequently incorporated within the Work."+ , ""+ , " 2. Grant of Copyright License. Subject to the terms and conditions of"+ , " this License, each Contributor hereby grants to You a perpetual,"+ , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable"+ , " copyright license to reproduce, prepare Derivative Works of,"+ , " publicly display, publicly perform, sublicense, and distribute the"+ , " Work and such Derivative Works in Source or Object form."+ , ""+ , " 3. Grant of Patent License. Subject to the terms and conditions of"+ , " this License, each Contributor hereby grants to You a perpetual,"+ , " worldwide, non-exclusive, no-charge, royalty-free, irrevocable"+ , " (except as stated in this section) patent license to make, have made,"+ , " use, offer to sell, sell, import, and otherwise transfer the Work,"+ , " where such license applies only to those patent claims licensable"+ , " by such Contributor that are necessarily infringed by their"+ , " Contribution(s) alone or by combination of their Contribution(s)"+ , " with the Work to which such Contribution(s) was submitted. If You"+ , " institute patent litigation against any entity (including a"+ , " cross-claim or counterclaim in a lawsuit) alleging that the Work"+ , " or a Contribution incorporated within the Work constitutes direct"+ , " or contributory patent infringement, then any patent licenses"+ , " granted to You under this License for that Work shall terminate"+ , " as of the date such litigation is filed."+ , ""+ , " 4. Redistribution. You may reproduce and distribute copies of the"+ , " Work or Derivative Works thereof in any medium, with or without"+ , " modifications, and in Source or Object form, provided that You"+ , " meet the following conditions:"+ , ""+ , " (a) You must give any other recipients of the Work or"+ , " Derivative Works a copy of this License; and"+ , ""+ , " (b) You must cause any modified files to carry prominent notices"+ , " stating that You changed the files; and"+ , ""+ , " (c) You must retain, in the Source form of any Derivative Works"+ , " that You distribute, all copyright, patent, trademark, and"+ , " attribution notices from the Source form of the Work,"+ , " excluding those notices that do not pertain to any part of"+ , " the Derivative Works; and"+ , ""+ , " (d) If the Work includes a \"NOTICE\" text file as part of its"+ , " distribution, then any Derivative Works that You distribute must"+ , " include a readable copy of the attribution notices contained"+ , " within such NOTICE file, excluding those notices that do not"+ , " pertain to any part of the Derivative Works, in at least one"+ , " of the following places: within a NOTICE text file distributed"+ , " as part of the Derivative Works; within the Source form or"+ , " documentation, if provided along with the Derivative Works; or,"+ , " within a display generated by the Derivative Works, if and"+ , " wherever such third-party notices normally appear. The contents"+ , " of the NOTICE file are for informational purposes only and"+ , " do not modify the License. You may add Your own attribution"+ , " notices within Derivative Works that You distribute, alongside"+ , " or as an addendum to the NOTICE text from the Work, provided"+ , " that such additional attribution notices cannot be construed"+ , " as modifying the License."+ , ""+ , " You may add Your own copyright statement to Your modifications and"+ , " may provide additional or different license terms and conditions"+ , " for use, reproduction, or distribution of Your modifications, or"+ , " for any such Derivative Works as a whole, provided Your use,"+ , " reproduction, and distribution of the Work otherwise complies with"+ , " the conditions stated in this License."+ , ""+ , " 5. Submission of Contributions. Unless You explicitly state otherwise,"+ , " any Contribution intentionally submitted for inclusion in the Work"+ , " by You to the Licensor shall be under the terms and conditions of"+ , " this License, without any additional terms or conditions."+ , " Notwithstanding the above, nothing herein shall supersede or modify"+ , " the terms of any separate license agreement you may have executed"+ , " with Licensor regarding such Contributions."+ , ""+ , " 6. Trademarks. This License does not grant permission to use the trade"+ , " names, trademarks, service marks, or product names of the Licensor,"+ , " except as required for reasonable and customary use in describing the"+ , " origin of the Work and reproducing the content of the NOTICE file."+ , ""+ , " 7. Disclaimer of Warranty. Unless required by applicable law or"+ , " agreed to in writing, Licensor provides the Work (and each"+ , " Contributor provides its Contributions) on an \"AS IS\" BASIS,"+ , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or"+ , " implied, including, without limitation, any warranties or conditions"+ , " of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A"+ , " PARTICULAR PURPOSE. You are solely responsible for determining the"+ , " appropriateness of using or redistributing the Work and assume any"+ , " risks associated with Your exercise of permissions under this License."+ , ""+ , " 8. Limitation of Liability. In no event and under no legal theory,"+ , " whether in tort (including negligence), contract, or otherwise,"+ , " unless required by applicable law (such as deliberate and grossly"+ , " negligent acts) or agreed to in writing, shall any Contributor be"+ , " liable to You for damages, including any direct, indirect, special,"+ , " incidental, or consequential damages of any character arising as a"+ , " result of this License or out of the use or inability to use the"+ , " Work (including but not limited to damages for loss of goodwill,"+ , " work stoppage, computer failure or malfunction, or any and all"+ , " other commercial damages or losses), even if such Contributor"+ , " has been advised of the possibility of such damages."+ , ""+ , " 9. Accepting Warranty or Additional Liability. While redistributing"+ , " the Work or Derivative Works thereof, You may choose to offer,"+ , " and charge a fee for, acceptance of support, warranty, indemnity,"+ , " or other liability obligations and/or rights consistent with this"+ , " License. However, in accepting such obligations, You may act only"+ , " on Your own behalf and on Your sole responsibility, not on behalf"+ , " of any other Contributor, and only if You agree to indemnify,"+ , " defend, and hold each Contributor harmless for any liability"+ , " incurred by, or claims asserted against, such Contributor by reason"+ , " of your accepting any such warranty or additional liability."+ , ""+ , " END OF TERMS AND CONDITIONS"+ , ""+ , " APPENDIX: How to apply the Apache License to your work."+ , ""+ , " To apply the Apache License to your work, attach the following"+ , " boilerplate notice, with the fields enclosed by brackets \"[]\""+ , " replaced with your own identifying information. (Don't include"+ , " the brackets!) The text should be enclosed in the appropriate"+ , " comment syntax for the file format. We also recommend that a"+ , " file or class name and description of purpose be included on the"+ , " same \"printed page\" as the copyright notice for easier"+ , " identification within third-party archives."+ , ""+ , " Copyright [yyyy] [name of copyright owner]"+ , ""+ , " Licensed under the Apache License, Version 2.0 (the \"License\");"+ , " you may not use this file except in compliance with the License."+ , " You may obtain a copy of the License at"+ , ""+ , " http://www.apache.org/licenses/LICENSE-2.0"+ , ""+ , " Unless required by applicable law or agreed to in writing, software"+ , " distributed under the License is distributed on an \"AS IS\" BASIS,"+ , " WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied."+ , " See the License for the specific language governing permissions and"+ , " limitations under the License."+ ]
Distribution/Client/Install.hs view
@@ -22,8 +22,10 @@ ( unfoldr, nub, sort, (\\) ) import Data.Maybe ( isJust, fromMaybe, maybeToList )+import qualified Data.ByteString.Lazy.Char8 as BS+ ( unpack ) import Control.Exception as Exception- ( handleJust )+ ( bracket, handleJust ) #if MIN_VERSION_base(4,0,0) import Control.Exception as Exception ( Exception(toException), catches, Handler(Handler), IOException )@@ -42,7 +44,7 @@ import System.FilePath ( (</>), (<.>), takeDirectory ) import System.IO- ( openFile, IOMode(AppendMode), stdout, hFlush )+ ( openFile, IOMode(AppendMode), stdout, hFlush, hClose ) import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) @@ -78,6 +80,7 @@ import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed import Paths_cabal_install_bundle (getBinDir)+import Distribution.Client.JobControl import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor@@ -92,14 +95,14 @@ , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal ( installCommand, InstallFlags(..), emptyInstallFlags- , emptyTestFlags, testCommand )+ , emptyTestFlags, testCommand, Flag(..) ) import Distribution.Simple.Utils- ( rawSystemExit, comparing )+ ( rawSystemExit, comparing, writeFileAtomic ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package- ( PackageIdentifier, packageName, packageVersion+ ( PackageIdentifier, PackageId, packageName, packageVersion , Package(..), PackageFixedDeps(..) , Dependency(..), thisPackageVersion, InstalledPackageId ) import qualified Distribution.PackageDescription as PackageDescription@@ -113,7 +116,7 @@ import Distribution.Simple.Utils as Utils ( notice, info, warn, die, intercalate, withTempDirectory ) import Distribution.Client.Utils- ( inDir, mergeBy, MergeResult(..) )+ ( numberOfProcessors, inDir, mergeBy, MergeResult(..) ) import Distribution.System ( Platform, buildPlatform, OS(Windows), buildOS ) import Distribution.Text@@ -409,16 +412,20 @@ linearizeInstallPlan :: PackageIndex -> InstallPlan -> [(ConfiguredPackage, PackageStatus)]-linearizeInstallPlan installedPkgIndex plan = unfoldr next plan+linearizeInstallPlan installedPkgIndex plan =+ unfoldr next plan where next plan' = case InstallPlan.ready plan' of [] -> Nothing- (pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan')- where pkgid = packageId pkg- status = packageStatus installedPkgIndex pkg- result = BuildOk DocsNotTried TestsNotTried- --FIXME: This is a bit of a hack,- -- pretending that each package is installed+ (pkg:_) -> Just ((pkg, status), plan'')+ where+ pkgid = packageId pkg+ status = packageStatus installedPkgIndex pkg+ plan'' = InstallPlan.completed pkgid+ (BuildOk DocsNotTried TestsNotTried)+ (InstallPlan.processing [pkg] plan')+ --FIXME: This is a bit of a hack,+ -- pretending that each package is installed data PackageStatus = NewPackage | NewVersion [Version]@@ -727,6 +734,10 @@ libVersion :: Maybe Version } +-- | If logging is enabled, contains location of the log file and the verbosity+-- level for logging.+type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)+ performInstallations :: Verbosity -> InstallContext -> PackageIndex@@ -737,21 +748,35 @@ globalFlags, configFlags, configExFlags, installFlags, haddockFlags) installedPkgIndex installPlan = do - executeInstallPlan installPlan $ \cpkg ->+ jobControl <- if parallelBuild then newParallelJobControl+ else newSerialJobControl+ buildLimit <- newJobLimit numJobs+ fetchLimit <- newJobLimit (min numJobs numFetchJobs)+ installLock <- newLock -- serialise installation+ cacheLock <- newLock -- serialise access to setup exe cache++ executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags- cpkg $ \configFlags' src pkg ->- fetchSourcePackage verbosity src $ \src' ->- installLocalPackage verbosity (packageId pkg) src' $ \mpath ->- installUnpackedPackage verbosity- (setupScriptOptions installedPkgIndex)+ cpkg $ \configFlags' src pkg pkgoverride ->+ fetchSourcePackage verbosity fetchLimit src $ \src' ->+ installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->+ installUnpackedPackage verbosity buildLimit installLock numJobs+ (setupScriptOptions installedPkgIndex cacheLock) miscOptions configFlags' installFlags haddockFlags- compid pkg mpath useLogFile+ compid pkg pkgoverride mpath useLogFile where platform = InstallPlan.planPlatform installPlan compid = InstallPlan.planCompiler installPlan - setupScriptOptions index = SetupScriptOptions {+ numJobs = case installNumJobs installFlags of+ Cabal.NoFlag -> 1+ Cabal.Flag Nothing -> numberOfProcessors+ Cabal.Flag (Just n) -> n+ numFetchJobs = 2+ parallelBuild = numJobs >= 2++ setupScriptOptions index lock = SetupScriptOptions { useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), useCompiler = Just comp, -- Hack: we typically want to allow the UserPackageDB for finding the@@ -771,23 +796,56 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags), useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useWorkingDir = Nothing,+ forceExternalSetupMethod = parallelBuild,+ setupCacheLock = Just lock } reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags)- useLogFile :: Maybe (PackageIdentifier -> FilePath)- useLogFile = fmap substLogFileName logFileTemplate++ -- Should the build output be written to a log file instead of stdout?+ useLogFile :: UseLogFile+ useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)+ logFileTemplate where+ installLogFile' = flagToMaybe $ installLogFile installFlags+ defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"++ -- 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). logFileTemplate :: Maybe PathTemplate- logFileTemplate --TODO: separate policy from mechanism- | reportingLevel == DetailedReports- = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"- | otherwise- = flagToMaybe (installLogFile installFlags)+ logFileTemplate+ | useDefaultTemplate = Just defaultTemplate+ | otherwise = installLogFile'++ -- If the user has specified --remote-build-reporting=detailed or+ -- --build-log, use more verbose logging.+ loggingVerbosity :: Verbosity+ loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity+ | otherwise = verbosity++ useDefaultTemplate :: Bool+ useDefaultTemplate+ | reportingLevel == DetailedReports = True+ | isJust installLogFile' = False+ | parallelBuild = True+ | otherwise = False++ overrideVerbosity :: Bool+ overrideVerbosity+ | reportingLevel == DetailedReports = True+ | isJust installLogFile' = True+ | parallelBuild = False+ | otherwise = False++ substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath substLogFileName template pkg = fromPathTemplate . substPathTemplate env $ template where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+ miscOptions = InstallMisc { rootCmd = if fromFlag (configUserInstall configFlags) then Nothing -- ignore --root-cmd if --user.@@ -796,16 +854,41 @@ } -executeInstallPlan :: Monad m- => InstallPlan- -> (ConfiguredPackage -> m BuildResult)- -> m InstallPlan-executeInstallPlan plan installPkg = case InstallPlan.ready plan of- [] -> return plan- (pkg: _) -> do buildResult <- installPkg pkg- let plan' = updatePlan (packageId pkg) buildResult plan- executeInstallPlan plan' installPkg+executeInstallPlan :: Verbosity+ -> JobControl IO (PackageId, BuildResult)+ -> UseLogFile+ -> InstallPlan+ -> (ConfiguredPackage -> IO BuildResult)+ -> IO InstallPlan+executeInstallPlan verbosity jobCtl useLogFile 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 info verbosity $ "Ready to install " ++ display pkgid+ spawnJob jobCtl $ do+ buildResult <- installPkg pkg+ return (packageId 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+ info verbosity $ "Waiting for install task to finish..."+ (pkgid, buildResult) <- collectJob jobCtl+ printBuildResult pkgid buildResult+ let taskCount' = taskCount-1+ plan' = updatePlan pkgid buildResult plan+ tryNewTasks taskCount' plan'++ updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan updatePlan pkgid (Right buildSuccess) = InstallPlan.completed pkgid buildSuccess @@ -818,7 +901,28 @@ -- now cannot build, we mark as failing due to 'DependentFailed' -- which kind of means it was not their fault. + -- Print last 10 lines of the build log if something went wrong, and+ -- 'Installed $PKGID' otherwise.+ printBuildResult :: PackageId -> BuildResult -> IO ()+ printBuildResult pkgid buildResult = case buildResult of+ (Right _) -> notice verbosity $ "Installed " ++ display pkgid+ (Left _) -> do+ notice verbosity $ "Failed to install " ++ display pkgid+ case useLogFile of+ Nothing -> return ()+ Just (mkLogFileName, _) -> do+ let (logName, n) = (mkLogFileName pkgid, 10)+ notice verbosity $ "Last " ++ (show n)+ ++ " lines of the build log ( " ++ logName ++ " ):"+ printLastNLines logName n + printLastNLines :: FilePath -> Int -> IO ()+ printLastNLines path n = do+ lns <- fmap lines $ readFile path+ let len = length lns+ let toDrop = if len > n && n > 0 then (len - n) else 0+ mapM_ (notice verbosity) (drop toDrop lns)+ -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly@@ -828,16 +932,17 @@ installConfiguredPackage :: Platform -> CompilerId -> ConfigFlags -> ConfiguredPackage -> (ConfigFlags -> PackageLocation (Maybe FilePath)- -> PackageDescription -> a)+ -> PackageDescription+ -> PackageDescriptionOverride -> a) -> a installConfiguredPackage platform comp configFlags- (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps)+ (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride) flags stanzas deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags, configConstraints = map thisPackageVersion deps, configBenchmarks = toFlag False, configTests = toFlag (TestStanzas `elem` stanzas)- } source pkg+ } source pkg pkgoverride where pkg = case finalizePackageDescription flags (const True)@@ -847,78 +952,112 @@ fetchSourcePackage :: Verbosity+ -> JobLimit -> PackageLocation (Maybe FilePath) -> (PackageLocation FilePath -> IO BuildResult) -> IO BuildResult-fetchSourcePackage verbosity src installPkg = do+fetchSourcePackage verbosity fetchLimit src installPkg = do fetched <- checkFetched src case fetched of Just src' -> installPkg src'- Nothing -> onFailure DownloadFailed $- fetchPackage verbosity src >>= installPkg+ Nothing -> onFailure DownloadFailed $ do+ loc <- withJobLimit fetchLimit $+ fetchPackage verbosity src+ installPkg loc installLocalPackage- :: Verbosity -> PackageIdentifier -> PackageLocation FilePath+ :: Verbosity+ -> JobLimit+ -> PackageIdentifier -> PackageLocation FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult-installLocalPackage verbosity pkgid location installPkg = case location of+installLocalPackage verbosity jobLimit pkgid location installPkg = + case location of+ LocalUnpackedPackage dir -> installPkg (Just dir) LocalTarballPackage tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg RemoteTarballPackage _ tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg RepoTarballPackage _ _ tarballPath ->- installLocalTarballPackage verbosity pkgid tarballPath installPkg+ installLocalTarballPackage verbosity jobLimit+ pkgid tarballPath installPkg installLocalTarballPackage- :: Verbosity -> PackageIdentifier -> FilePath+ :: Verbosity+ -> JobLimit+ -> PackageIdentifier -> FilePath -> (Maybe FilePath -> IO BuildResult) -> IO BuildResult-installLocalTarballPackage verbosity pkgid tarballPath installPkg = do+installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do tmp <- getTemporaryDirectory withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> onFailure UnpackFailed $ do- info verbosity $ "Extracting " ++ tarballPath- ++ " to " ++ tmpDirPath ++ "..." let relUnpackedPath = display pkgid absUnpackedPath = tmpDirPath </> relUnpackedPath descFilePath = absUnpackedPath </> display (packageName pkgid) <.> "cabal"- extractTarGzFile tmpDirPath relUnpackedPath tarballPath- exists <- doesFileExist descFilePath- when (not exists) $- die $ "Package .cabal file not found: " ++ show descFilePath+ withJobLimit jobLimit $ do+ info verbosity $ "Extracting " ++ tarballPath+ ++ " to " ++ tmpDirPath ++ "..."+ extractTarGzFile tmpDirPath relUnpackedPath tarballPath+ exists <- doesFileExist descFilePath+ when (not exists) $+ die $ "Package .cabal file not found: " ++ show descFilePath installPkg (Just absUnpackedPath) -installUnpackedPackage :: Verbosity- -> SetupScriptOptions- -> InstallMisc- -> ConfigFlags- -> InstallFlags- -> HaddockFlags- -> CompilerId- -> PackageDescription- -> Maybe FilePath -- ^ Directory to change to before starting the installation.- -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)- -> IO BuildResult-installUnpackedPackage verbosity scriptOptions miscOptions+installUnpackedPackage+ :: Verbosity+ -> JobLimit+ -> Lock+ -> Int+ -> SetupScriptOptions+ -> InstallMisc+ -> ConfigFlags+ -> InstallFlags+ -> HaddockFlags+ -> CompilerId+ -> PackageDescription+ -> 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+ scriptOptions miscOptions configFlags installConfigFlags haddockFlags- compid pkg workingDir useLogFile =+ compid pkg pkgoverride workingDir useLogFile = do + -- Override the .cabal file if necessary+ case pkgoverride of+ Nothing -> return ()+ Just pkgtxt -> do+ let descFilePath = fromMaybe "." workingDir+ </> display (packageName pkgid) <.> "cabal"+ info verbosity $+ "Updating " ++ display (packageName pkgid) <.> "cabal"+ ++ " with the latest revision from the index."+ writeFileAtomic descFilePath (BS.unpack pkgtxt)+ -- Configure phase- onFailure ConfigureFailed $ do+ onFailure ConfigureFailed $ withJobLimit buildLimit $ do+ when (numJobs > 1) $ notice verbosity $+ "Configuring " ++ display pkgid ++ "..." setup configureCommand configureFlags -- Build phase onFailure BuildFailed $ do+ when (numJobs > 1) $ notice verbosity $+ "Building " ++ display pkgid ++ "..." setup buildCommand' buildFlags -- Doc generation phase@@ -938,7 +1077,7 @@ | otherwise = TestsNotTried -- Install phase- onFailure InstallFailed $+ onFailure InstallFailed $ criticalSection installLock $ withWin32SelfUpgrade verbosity configFlags compid pkg $ do case rootCmd miscOptions of (Just cmd) -> reexec cmd@@ -946,6 +1085,7 @@ return (Right (BuildOk docsResult testsResult)) where+ pkgid = packageId pkg configureFlags = filterConfigureFlags configFlags { configVerbosity = toFlag verbosity' }@@ -964,23 +1104,27 @@ Cabal.installDistPref = configDistPref configFlags, Cabal.installVerbosity = toFlag verbosity' }- verbosity' | isJust useLogFile = max Verbosity.verbose verbosity- | otherwise = verbosity- setup cmd flags = do- logFileHandle <- case useLogFile of- Nothing -> return Nothing- Just mkLogFileName -> do- let logFileName = mkLogFileName (packageId pkg)- logDir = takeDirectory logFileName- unless (null logDir) $ createDirectoryIfMissing True logDir- logFile <- openFile logFileName AppendMode- return (Just logFile)+ verbosity' = maybe verbosity snd useLogFile - setupWrapper verbosity- scriptOptions { useLoggingHandle = logFileHandle- , useWorkingDir = workingDir }- (Just pkg)- cmd flags []+ setup cmd flags = do+ Exception.bracket+ (case useLogFile of+ Nothing -> return Nothing+ Just (mkLogFileName, _) -> do+ let logFileName = mkLogFileName (packageId pkg)+ logDir = takeDirectory logFileName+ unless (null logDir) $ createDirectoryIfMissing True logDir+ logFile <- openFile logFileName AppendMode+ return (Just logFile))+ (\mHandle -> case mHandle of+ Just handle -> hClose handle+ Nothing -> return ())+ (\logFileHandle ->+ setupWrapper verbosity+ scriptOptions { useLoggingHandle = logFileHandle+ , useWorkingDir = workingDir }+ (Just pkg)+ cmd flags []) reexec cmd = do -- look for our on executable file and re-exec ourselves using -- a helper program like sudo to elevate priviledges:
Distribution/Client/InstallPlan.hs view
@@ -20,6 +20,7 @@ new, toList, ready,+ processing, completed, failed, remove,@@ -28,7 +29,7 @@ planPlatform, planCompiler, - -- * Checking valididy of plans+ -- * Checking validity of plans valid, closed, consistent,@@ -120,24 +121,27 @@ -- Note that plans do not necessarily compose. You might have a valid plan for -- package A and a valid plan for package B. That does not mean the composition--- is simultaniously valid for A and B. In particular you're most likely to+-- is simultaneously valid for A and B. In particular you're most likely to -- have problems with inconsistent dependencies. -- On the other hand it is true that every closed sub plan is valid. data PlanPackage = PreExisting InstalledPackage | Configured ConfiguredPackage+ | Processing ConfiguredPackage | Installed ConfiguredPackage BuildSuccess | Failed ConfiguredPackage BuildFailure instance Package PlanPackage where packageId (PreExisting pkg) = packageId pkg packageId (Configured pkg) = packageId pkg+ packageId (Processing pkg) = packageId pkg packageId (Installed pkg _) = packageId pkg packageId (Failed pkg _) = packageId pkg instance PackageFixedDeps PlanPackage where depends (PreExisting pkg) = depends pkg depends (Configured pkg) = depends pkg+ depends (Processing pkg) = depends pkg depends (Installed pkg _) = depends pkg depends (Failed pkg _) = depends pkg @@ -203,13 +207,16 @@ ready :: InstallPlan -> [ConfiguredPackage] ready plan = assert check readyPackages where- check = if null readyPackages then null configuredPackages else True- configuredPackages =- [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]+ check = if null readyPackages && null processingPackages+ then null configuredPackages+ else True+ configuredPackages = [ pkg | Configured pkg <- toList plan ]+ processingPackages = [ pkg | Processing pkg <- toList plan] readyPackages = filter (all isInstalled . depends) configuredPackages isInstalled pkg = case PackageIndex.lookupPackageId (planIndex plan) pkg of Just (Configured _) -> False+ Just (Processing _) -> False Just (Failed _ _) -> internalError depOnFailed Just (PreExisting _) -> True Just (Installed _ _) -> True@@ -217,10 +224,22 @@ incomplete = "install plan is not closed" depOnFailed = "configured package depends on failed package" +-- | Marks packages in the graph as currently processing (e.g. building).+--+-- * The package must exist in the graph and be in the configured state.+--+processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan+processing pkgs plan = assert (invariant plan') plan'+ where+ plan' = plan {+ planIndex = PackageIndex.merge (planIndex plan) processingPkgs+ }+ processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs]+ -- | Marks a package in the graph as completed. Also saves the build result for -- the completed package in the plan. ----- * The package must exist in the graph.+-- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. -- completed :: PackageIdentifier@@ -231,12 +250,13 @@ plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }- installed = Installed (lookupConfiguredPackage plan pkgid) buildResult+ installed = Installed (lookupProcessingPackage plan pkgid) buildResult -- | Marks a package in the graph as having failed. It also marks all the -- packages that depended on it as having failed. ----- * The package must exist in the graph and be in the configured state.+-- * The package must exist in the graph and be in the processing+-- state. -- failed :: PackageIdentifier -- ^ The id of the package that failed to install -> BuildFailure -- ^ The build result to use for the failed package@@ -248,14 +268,14 @@ plan' = plan { planIndex = PackageIndex.merge (planIndex plan) failures }- pkg = lookupConfiguredPackage plan pkgid+ pkg = lookupProcessingPackage plan pkgid failures = PackageIndex.fromList $ Failed pkg buildResult : [ Failed pkg' buildResult' | Just pkg' <- map checkConfiguredPackage $ packagesThatDependOn plan pkgid ] --- | lookup the reachable packages in the reverse dependency graph+-- | Lookup the reachable packages in the reverse dependency graph. -- packagesThatDependOn :: InstallPlan -> PackageIdentifier -> [PlanPackage]@@ -264,16 +284,16 @@ . Graph.reachable (planGraphRev plan) . planVertexOf plan --- | lookup a package that we expect to be in the configured state+-- | Lookup a package that we expect to be in the processing state. ---lookupConfiguredPackage :: InstallPlan+lookupProcessingPackage :: InstallPlan -> PackageIdentifier -> ConfiguredPackage-lookupConfiguredPackage plan pkgid =+lookupProcessingPackage plan pkgid = case PackageIndex.lookupPackageId (planIndex plan) pkgid of- Just (Configured pkg) -> pkg- _ -> internalError $ "not configured or no such pkg " ++ display pkgid+ Just (Processing pkg) -> pkg+ _ -> internalError $ "not in processing state or no such pkg " ++ display pkgid --- | check a package that we expect to be in the configured or failed state+-- | Check a package that we expect to be in the configured or failed state. -- checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage checkConfiguredPackage (Configured pkg) = Just pkg@@ -334,6 +354,7 @@ where showPlanState (PreExisting _) = "pre-existing" showPlanState (Configured _) = "configured"+ showPlanState (Processing _) = "processing" showPlanState (Installed _ _) = "installed" showPlanState (Failed _ _) = "failed" @@ -409,8 +430,12 @@ stateDependencyRelation (Configured _) (PreExisting _) = True stateDependencyRelation (Configured _) (Configured _) = True+stateDependencyRelation (Configured _) (Processing _) = True stateDependencyRelation (Configured _) (Installed _ _) = True +stateDependencyRelation (Processing _) (PreExisting _) = True+stateDependencyRelation (Processing _) (Installed _ _) = True+ stateDependencyRelation (Installed _ _) (PreExisting _) = True stateDependencyRelation (Installed _ _) (Installed _ _) = True @@ -419,6 +444,7 @@ -- several other packages and if one of the deps fail then we fail -- but we still depend on the other ones that did not fail: stateDependencyRelation (Failed _ _) (Configured _) = True+stateDependencyRelation (Failed _ _) (Processing _) = True stateDependencyRelation (Failed _ _) (Installed _ _) = True stateDependencyRelation (Failed _ _) (Failed _ _) = True
Distribution/Client/InstallSymlink.hs view
@@ -67,9 +67,10 @@ import System.FilePath ( (</>), splitPath, joinPath, isAbsolute ) -import Prelude hiding (catch, ioError)+import Prelude hiding (ioError) import System.IO.Error- ( catch, isDoesNotExistError, ioError )+ ( isDoesNotExistError, ioError )+import Distribution.Compat.Exception ( catchIO ) import Control.Exception ( assert ) import Data.Maybe@@ -132,7 +133,7 @@ , PackageDescription.buildable (PackageDescription.buildInfo exe) ] pkgDescription :: ConfiguredPackage -> PackageDescription- pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) =+ pkgDescription (ConfiguredPackage (SourcePackage _ pkg _ _) flags stanzas _) = case finalizePackageDescription flags (const True) platform compilerId [] (enableStanzas stanzas pkg) of@@ -209,7 +210,7 @@ else return NotOurFile where- handleNotExist action = catch action $ \ioexception ->+ handleNotExist action = catchIO action $ \ioexception -> -- If the target doesn't exist then there's no problem overwriting it! if isDoesNotExistError ioexception then return NotExists
Distribution/Client/Setup.hs view
@@ -62,7 +62,7 @@ import Distribution.Package ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) import Distribution.Text- ( Text(parse), display )+ ( Text(..), display ) import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse@@ -475,13 +475,15 @@ data UnpackFlags = UnpackFlags { unpackDestDir :: Flag FilePath,- unpackVerbosity :: Flag Verbosity+ unpackVerbosity :: Flag Verbosity,+ unpackPristine :: Flag Bool } defaultUnpackFlags :: UnpackFlags defaultUnpackFlags = UnpackFlags { unpackDestDir = mempty,- unpackVerbosity = toFlag normal+ unpackVerbosity = toFlag normal,+ unpackPristine = toFlag False } unpackCommand :: CommandUI UnpackFlags@@ -498,14 +500,21 @@ "where to unpack the packages, defaults to the current directory." unpackDestDir (\v flags -> flags { unpackDestDir = v }) (reqArgFlag "PATH")++ , option [] ["pristine"]+ ("Unpack the original pristine tarball, rather than updating the "+ ++ ".cabal file with the latest revision from the package archive.")+ unpackPristine (\v flags -> flags { unpackPristine = v })+ trueArg ] } instance Monoid UnpackFlags where mempty = defaultUnpackFlags mappend a b = UnpackFlags {- unpackDestDir = combine unpackDestDir- ,unpackVerbosity = combine unpackVerbosity+ unpackDestDir = combine unpackDestDir,+ unpackVerbosity = combine unpackVerbosity,+ unpackPristine = combine unpackPristine } where combine field = field a `mappend` field b @@ -615,7 +624,8 @@ installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, installSymlinkBinDir :: Flag FilePath,- installOneShot :: Flag Bool+ installOneShot :: Flag Bool,+ installNumJobs :: Flag (Maybe Int) } defaultInstallFlags :: InstallFlags@@ -638,7 +648,8 @@ installLogFile = mempty, installBuildReports = Flag NoReports, installSymlinkBinDir = mempty,- installOneShot = Flag False+ installOneShot = Flag False,+ installNumJobs = mempty } where docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")@@ -786,6 +797,15 @@ "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) (yesNoOpt showOrParseArgs)++ , option "j" ["jobs"]+ "Run NUM jobs simultaneously."+ installNumJobs (\v flags -> flags { installNumJobs = v })+ (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number")+ (fmap (toFlag . Just)+ (Parse.readS_to_P reads)))+ (Flag Nothing)+ (map (fmap show) . flagToList)) ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"]@@ -815,7 +835,8 @@ installLogFile = mempty, installBuildReports = mempty, installSymlinkBinDir = mempty,- installOneShot = mempty+ installOneShot = mempty,+ installNumJobs = mempty } mappend a b = InstallFlags { installDocumentation = combine installDocumentation,@@ -836,7 +857,8 @@ installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, installSymlinkBinDir = combine installSymlinkBinDir,- installOneShot = combine installOneShot+ installOneShot = combine installOneShot,+ installNumJobs = combine installNumJobs } where combine field = field a `mappend` field b
Distribution/Client/SetupWrapper.hs view
@@ -20,9 +20,6 @@ defaultSetupScriptOptions, ) where -import Distribution.Client.Types- ( InstalledPackage )- import qualified Distribution.Make as Make import qualified Distribution.Simple as Simple import Distribution.Version@@ -41,10 +38,11 @@ import Distribution.Simple.Configure ( configCompiler ) import Distribution.Simple.Compiler- ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack )+ ( CompilerFlavor(GHC), Compiler, compilerVersion, showCompilerId+ , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration, emptyProgramConfiguration- , rawSystemProgramConf, ghcProgram )+ , getDbProgramOutput, runDbProgram, ghcProgram ) import Distribution.Simple.BuildPaths ( defaultDistPref, exeExtension ) import Distribution.Simple.Command@@ -53,21 +51,28 @@ ( ghcVerbosityOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Client.Config+ ( defaultCabalDir ) import Distribution.Client.IndexUtils ( getInstalledPackages )+import Distribution.Client.JobControl+ ( Lock, criticalSection ) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing- , createDirectoryIfMissingVerbose, rewriteFile, intercalate )+ , createDirectoryIfMissingVerbose, installExecutableFile+ , rewriteFile, intercalate ) import Distribution.Client.Utils ( moreRecentFile, inDir ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity )+import Distribution.Compat.Exception+ ( catchIO ) -import System.Directory ( doesFileExist, getCurrentDirectory )+import System.Directory ( doesFileExist, canonicalizePath ) import System.FilePath ( (</>), (<.>) )-import System.IO ( Handle )+import System.IO ( Handle, hPutStr ) import System.Exit ( ExitCode(..), exitWith ) import System.Process ( runProcess, waitForProcess ) import Control.Monad ( when, unless )@@ -76,26 +81,33 @@ import Data.Char ( isSpace ) data SetupScriptOptions = SetupScriptOptions {- useCabalVersion :: VersionRange,- useCompiler :: Maybe Compiler,- usePackageDB :: PackageDBStack,- usePackageIndex :: Maybe PackageIndex,- useProgramConfig :: ProgramConfiguration,- useDistPref :: FilePath,- useLoggingHandle :: Maybe Handle,- useWorkingDir :: Maybe FilePath+ useCabalVersion :: VersionRange,+ useCompiler :: Maybe Compiler,+ usePackageDB :: PackageDBStack,+ usePackageIndex :: Maybe PackageIndex,+ useProgramConfig :: ProgramConfiguration,+ useDistPref :: FilePath,+ useLoggingHandle :: Maybe Handle,+ useWorkingDir :: Maybe FilePath,+ forceExternalSetupMethod :: Bool,++ -- Used only when calling setupWrapper from parallel code to serialise+ -- access to the setup cache; should be Nothing otherwise.+ setupCacheLock :: Maybe Lock } defaultSetupScriptOptions :: SetupScriptOptions defaultSetupScriptOptions = SetupScriptOptions {- useCabalVersion = anyVersion,- useCompiler = Nothing,- usePackageDB = [GlobalPackageDB, UserPackageDB],- usePackageIndex = Nothing,- useProgramConfig = emptyProgramConfiguration,- useDistPref = defaultDistPref,- useLoggingHandle = Nothing,- useWorkingDir = Nothing+ useCabalVersion = anyVersion,+ useCompiler = Nothing,+ usePackageDB = [GlobalPackageDB, UserPackageDB],+ usePackageIndex = Nothing,+ useProgramConfig = emptyProgramConfiguration,+ useDistPref = defaultDistPref,+ useLoggingHandle = Nothing,+ useWorkingDir = Nothing,+ forceExternalSetupMethod = False,+ setupCacheLock = Nothing } setupWrapper :: Verbosity@@ -135,11 +147,12 @@ -- determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod determineSetupMethod options buildType'+ | forceExternalSetupMethod options = externalSetupMethod | isJust (useLoggingHandle options)- || buildType' == Custom = externalSetupMethod+ || buildType' == Custom = externalSetupMethod | cabalVersion `withinRange`- useCabalVersion options = internalSetupMethod- | otherwise = externalSetupMethod+ useCabalVersion options = internalSetupMethod+ | otherwise = externalSetupMethod type SetupMethod = Verbosity -> SetupScriptOptions@@ -179,8 +192,10 @@ debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion setupHs <- updateSetupScript cabalLibVersion bt debug verbosity $ "Using " ++ setupHs ++ " as setup script."- compileSetupExecutable options' cabalLibVersion setupHs- invokeSetupScript (mkargs cabalLibVersion)+ path <- case bt of+ Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs+ _ -> compileSetupExecutable options' cabalLibVersion setupHs+ invokeSetupScript path (mkargs cabalLibVersion) where workingDir = case fromMaybe "" (useWorkingDir options) of@@ -188,7 +203,6 @@ dir -> dir setupDir = workingDir </> useDistPref options </> "setup" setupVersionFile = setupDir </> "setup" <.> "version"- setupProgFile = setupDir </> "setup" <.> exeExtension cabalLibVersionToUse :: IO (Version, SetupScriptOptions) cabalLibVersionToUse = do@@ -202,7 +216,7 @@ return (version, options') savedCabalVersion = do- versionString <- readFile setupVersionFile `catch` \_ -> return ""+ versionString <- readFile setupVersionFile `catchIO` \_ -> return "" case reads versionString of [(version,s)] | all isSpace s -> return (Just version) _ -> return Nothing@@ -276,51 +290,106 @@ Custom -> error "buildTypeScript Custom" UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + -- | Look up the setup executable in the cache; update the cache if the setup+ -- executable is not found.+ getCachedSetupExecutable :: SetupScriptOptions -> Version -> FilePath+ -> IO FilePath+ getCachedSetupExecutable options' cabalLibVersion setupHsFile = do+ cabalDir <- defaultCabalDir+ let setupCacheDir = cabalDir </> "setup-exe-cache"+ let setupProgFile = setupCacheDir+ </> ("setup-" ++ cabalVersionString ++ "-"+ ++ compilerVersionString)+ <.> exeExtension+ setupProgFileExists <- doesFileExist setupProgFile+ if setupProgFileExists+ then debug verbosity $+ "Found cached setup executable: " ++ setupProgFile+ else criticalSection' $ do+ -- The cache may have been populated while we were waiting.+ setupProgFileExists' <- doesFileExist setupProgFile+ if setupProgFileExists'+ then debug verbosity $+ "Found cached setup executable: " ++ setupProgFile+ else do+ debug verbosity $ "Setup executable not found in the cache."+ src <- compileSetupExecutable options' cabalLibVersion setupHsFile+ createDirectoryIfMissingVerbose verbosity True setupCacheDir+ installExecutableFile verbosity src setupProgFile+ return setupProgFile+ where+ cabalVersionString = "Cabal-" ++ (display cabalLibVersion)+ compilerVersionString = fromMaybe "nonexisting-compiler"+ (showCompilerId `fmap` useCompiler options')+ criticalSection' = fromMaybe id+ (fmap criticalSection $ setupCacheLock options')+ -- | If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC only. It should really be generalised. --- compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()+ compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath+ -> IO FilePath compileSetupExecutable options' cabalLibVersion setupHsFile = do setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile let outOfDate = setupHsNewer || cabalVersionNewer when outOfDate $ do debug verbosity "Setup script is out of date, compiling..."- (_, conf, _) <- configureCompiler options'+ (compiler, conf, _) <- configureCompiler options' --TODO: get Cabal's GHC module to export a GhcOptions type and render func- rawSystemProgramConf verbosity ghcProgram conf $- ghcVerbosityOptions verbosity- ++ ["--make", setupHsFile, "-o", setupProgFile- ,"-odir", setupDir, "-hidir", setupDir- ,"-i", "-i" ++ workingDir ]- ++ ghcPackageDbOptions (usePackageDB options')- ++ if packageName pkg == PackageName "Cabal"- then []- else ["-package", display cabalPkgid]+ let ghcCmdLine =+ ghcVerbosityOptions verbosity+ ++ ["--make", setupHsFile, "-o", setupProgFile+ ,"-odir", setupDir, "-hidir", setupDir+ ,"-i", "-i" ++ workingDir ]+ ++ ghcPackageDbOptions compiler (usePackageDB options')+ ++ if packageName pkg == PackageName "Cabal"+ then []+ else ["-package", display cabalPkgid]+ case useLoggingHandle options of+ Nothing -> runDbProgram verbosity ghcProgram conf ghcCmdLine++ -- If build logging is enabled, redirect compiler output to the log file.+ (Just logHandle) -> do output <- getDbProgramOutput verbosity ghcProgram+ conf ghcCmdLine+ hPutStr logHandle output+ return setupProgFile where- cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+ setupProgFile = setupDir </> "setup" <.> exeExtension+ cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - ghcPackageDbOptions :: PackageDBStack -> [String]- ghcPackageDbOptions dbstack = case dbstack of+ ghcPackageDbOptions :: Compiler -> PackageDBStack -> [String]+ ghcPackageDbOptions compiler dbstack = case dbstack of (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> "-no-user-package-conf"+ (GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag) : concatMap specific dbs _ -> ierror where- specific (SpecificPackageDB db) = [ "-package-conf", db ]+ specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ] specific _ = ierror ierror = error "internal error: unexpected package db stack" + packageDbFlag+ | compilerVersion compiler < Version [7,5] []+ = "package-conf"+ | otherwise+ = "package-db" - invokeSetupScript :: [String] -> IO ()- invokeSetupScript args = do- info verbosity $ unwords (setupProgFile : args)+ invokeSetupScript :: FilePath -> [String] -> IO ()+ invokeSetupScript path args = do+ info verbosity $ unwords (path : args) case useLoggingHandle options of Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle- currentDir <- getCurrentDirectory- process <- runProcess (currentDir </> setupProgFile) args++ -- Since useWorkingDir can change the relative path, the path argument must+ -- be turned into an absolute path. On some systems, runProcess will take+ -- path as relative to the new working directory instead of the current+ -- working directory.+ path' <- canonicalizePath path++ process <- runProcess path' args (useWorkingDir options) Nothing Nothing (useLoggingHandle options) (useLoggingHandle options) exitCode <- waitForProcess process
Distribution/Client/Tar.hs view
@@ -87,8 +87,7 @@ ( setFileExecutable ) import System.Posix.Types ( FileMode )-import System.Time- ( ClockTime(..) )+import Distribution.Compat.Time import System.IO ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO)@@ -119,8 +118,6 @@ -- type FileSize = Int64--- | The number of seconds since the UNIX epoch-type EpochTime = Int64 type DevMajor = Int type DevMinor = Int type TypeCode = Char@@ -264,12 +261,12 @@ -- * Tar paths -- --- | The classic tar format allowed just 100 charcters for the file name. The+-- | 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 agrevating insane bit however is that 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@@ -896,8 +893,3 @@ ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False--getModTime :: FilePath -> IO EpochTime-getModTime path = do- (TOD s _) <- getModificationTime path- return $! fromIntegral s
Distribution/Client/Targets.hs view
@@ -472,9 +472,10 @@ pkg <- readPackageDescription verbosity =<< findPackageDesc dir return $ PackageTargetLocation $ SourcePackage {- packageInfoId = packageId pkg,- packageDescription = pkg,- packageSource = fmap Just location+ packageInfoId = packageId pkg,+ packageDescription = pkg,+ packageSource = fmap Just location,+ packageDescrOverride = Nothing } LocalTarballPackage tarballFile ->@@ -497,9 +498,10 @@ Just pkg -> return $ PackageTargetLocation $ SourcePackage {- packageInfoId = packageId pkg,- packageDescription = pkg,- packageSource = fmap Just location+ packageInfoId = packageId pkg,+ packageDescription = pkg,+ packageSource = fmap Just location,+ packageDescrOverride = Nothing } extractTarballPackageCabalFile :: FilePath -> String
Distribution/Client/Types.hs view
@@ -29,6 +29,7 @@ import Data.Map (Map) import Network.URI (URI)+import Data.ByteString.Lazy (ByteString) import Distribution.Compat.Exception ( SomeException ) @@ -94,11 +95,16 @@ -- | A package description along with the location of the package sources. -- data SourcePackage = SourcePackage {- packageInfoId :: PackageId,- packageDescription :: GenericPackageDescription,- packageSource :: PackageLocation (Maybe FilePath)+ packageInfoId :: PackageId,+ packageDescription :: GenericPackageDescription,+ packageSource :: PackageLocation (Maybe FilePath),+ packageDescrOverride :: PackageDescriptionOverride } deriving Show++-- | 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
Distribution/Client/Unpack.hs view
@@ -19,11 +19,11 @@ ) where import Distribution.Package- ( PackageId, packageId )+ ( PackageId, packageId, packageName ) import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils- ( notice, die )+ ( notice, die, info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display)@@ -45,8 +45,9 @@ import Data.Monoid ( mempty ) import System.FilePath- ( (</>), addTrailingPathSeparator )-+ ( (</>), (<.>), addTrailingPathSeparator )+import qualified Data.ByteString.Lazy.Char8 as BS+ ( unpack ) unpack :: Verbosity -> [Repo]@@ -77,15 +78,17 @@ flip mapM_ pkgs $ \pkg -> do location <- fetchPackage verbosity (packageSource pkg) let pkgid = packageId pkg+ descOverride | usePristine = Nothing+ | otherwise = packageDescrOverride pkg case location of LocalTarballPackage tarballPath ->- unpackPackage verbosity prefix pkgid tarballPath+ unpackPackage verbosity prefix pkgid descOverride tarballPath RemoteTarballPackage _tarballURL tarballPath ->- unpackPackage verbosity prefix pkgid tarballPath+ unpackPackage verbosity prefix pkgid descOverride tarballPath RepoTarballPackage _repo _pkgid tarballPath ->- unpackPackage verbosity prefix pkgid tarballPath+ unpackPackage verbosity prefix pkgid descOverride tarballPath LocalUnpackedPackage _ -> error "Distribution.Client.Unpack.unpack: the impossible happened."@@ -97,6 +100,7 @@ standardInstallPolicy mempty sourcePkgDb pkgSpecifiers prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)+ usePristine = fromFlagOrDefault False (unpackPristine unpackFlags) checkTarget :: UserTarget -> IO () checkTarget target = case target of@@ -108,8 +112,10 @@ "The 'unpack' command is for tarball packages. " ++ "The target '" ++ t ++ "' is not a tarball." -unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()-unpackPackage verbosity prefix pkgid pkgPath = do+unpackPackage :: Verbosity -> FilePath -> PackageId+ -> PackageDescriptionOverride+ -> FilePath -> IO ()+unpackPackage verbosity prefix pkgid descOverride pkgPath = do let pkgdirname = display pkgid pkgdir = prefix </> pkgdirname pkgdir' = addTrailingPathSeparator pkgdir@@ -121,3 +127,12 @@ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath++ case descOverride of+ Nothing -> return ()+ Just pkgtxt -> do+ let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"+ info verbosity $+ "Updating " ++ descFilePath+ ++ " with the latest revision from the index."+ writeFileAtomic descFilePath (BS.unpack pkgtxt)
Distribution/Client/Utils.hs view
@@ -1,10 +1,17 @@-module Distribution.Client.Utils where+{-# LANGUAGE ForeignFunctionInterface #-} +module Distribution.Client.Utils ( MergeResult(..)+ , mergeBy, duplicates, duplicatesBy+ , moreRecentFile, inDir, numberOfProcessors )+ where+ import Data.List ( sortBy, groupBy )+import Foreign.C.Types ( CInt(..) ) import System.Directory ( doesFileExist, getModificationTime , getCurrentDirectory, setCurrentDirectory )+import System.IO.Unsafe ( unsafePerformIO ) import qualified Control.Exception as Exception ( finally ) @@ -58,3 +65,10 @@ old <- getCurrentDirectory setCurrentDirectory d m `Exception.finally` setCurrentDirectory old++foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt++-- The number of processors is not going to change during the duration of the+-- program, so unsafePerformIO is safe here.+numberOfProcessors :: Int+numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
Distribution/Client/World.hs view
@@ -40,6 +40,7 @@ import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( (<>), (<+>) ) @@ -117,7 +118,7 @@ else die "Could not parse world file." where safelyReadFile :: FilePath -> IO B.ByteString- safelyReadFile file = B.readFile file `catch` handler+ safelyReadFile file = B.readFile file `catchIO` handler where handler e | isDoesNotExistError e = return B.empty | otherwise = ioError e
Main.hs view
@@ -62,11 +62,12 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Simple.Compiler- ( Compiler, PackageDB(..), PackageDBStack )+ ( Compiler, PackageDBStack ) import Distribution.Simple.Program ( ProgramConfiguration, defaultProgramConfiguration ) import Distribution.Simple.Command-import Distribution.Simple.Configure (configCompilerAux)+import Distribution.Simple.Configure+ ( configCompilerAux, interpretPackageDbFlags ) import Distribution.Simple.Utils ( cabalVersion, die, topHandler, intercalate ) import Distribution.Text@@ -386,24 +387,9 @@ -- Utils (transitionary) -- --- | Currently the user interface specifies the package dbs to use with just a--- single valued option, a 'PackageDB'. However internally we represent the--- stack of 'PackageDB's explictly as a list. This function converts encodes--- the package db stack implicit in a single packagedb.------ TODO: sort this out, make it consistent with the command line UI-implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack-implicitPackageDbStack userInstall packageDbFlag- | userInstall = GlobalPackageDB : UserPackageDB : extra- | otherwise = GlobalPackageDB : extra- where- extra = case packageDbFlag of- Just (SpecificPackageDB db) -> [SpecificPackageDB db]- _ -> []- configPackageDB' :: ConfigFlags -> PackageDBStack configPackageDB' cfg =- implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))+ interpretPackageDbFlags userInstall (configPackageDBs cfg) where userInstall = fromFlagOrDefault True (configUserInstall cfg)
Network/Browser.hs view
@@ -495,7 +495,7 @@ setErrHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = modify (\b -> b { bsErr=h }) --- | @setErrHandler@ sets the IO action to call when+-- | @setOutHandler@ sets the IO action to call when -- the browser chatters info on its running. To disable any -- such, set it to @const (return ())@. setOutHandler :: (String -> IO ()) -> BrowserAction t ()@@ -809,7 +809,9 @@ case e_rsp of Left v | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && - (v == ErrorReset || v == ErrorClosed) ->+ (v == ErrorReset || v == ErrorClosed) -> do+ --empty connnection pool in case connection has become invalid+ modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq | otherwise -> return (Left v)
Network/HTTP.hs view
@@ -59,10 +59,12 @@ , module Network.TCP , getRequest -- :: String -> Request_String+ , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String , postRequestWithBody -- :: String -> String -> String -> Request_String - , getResponseBody -- :: Requesty ty -> ty+ , getResponseBody -- :: Result (Request ty) -> IO ty+ , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where -----------------------------------------------------------------@@ -142,29 +144,52 @@ respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = S.respondHTTP conn rsp --- | @getRequest urlString@ is convenience constructor for basic GET 'Request's. If--- @urlString@ isn't a syntactically valid URL, the function raises an error.-getRequest :: String -> Request_String++-- | A convenience constructor for a GET 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+getRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u --- | @postRequest urlString@ is convenience constructor for POST 'Request's. If--- @urlString@ isn\'t a syntactically valid URL, the function raises an error.-postRequest :: String -> Request_String+-- | A convenience constructor for a HEAD 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+headRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request+headRequest urlString = + case parseURI urlString of+ Nothing -> error ("headRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest HEAD u++-- | A convenience constructor for a POST 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequest+ :: String -- ^URL to POST to+ -> Request_String -- ^The constructed request postRequest urlString = case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u --- | @postRequestWithBody urlString typ body@ is convenience constructor for--- POST 'Request's. It constructs a request and sets the body as well as+-- | A convenience constructor for a POST 'Request'.+--+-- It constructs a request and sets the body as well as -- the Content-Type and Content-Length headers. The contents of the body -- are forced to calculate the value for the Content-Length header.--- If @urlString@ isn\'t a syntactically valid URL, the function raises--- an error.-postRequestWithBody :: String -> String -> String -> Request_String+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequestWithBody+ :: String -- ^URL to POST to+ -> String -- ^Content-Type of body+ -> String -- ^The body of the request+ -> Request_String -- ^The constructed request postRequestWithBody urlString typ body = case parseURI urlString of Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString)@@ -176,6 +201,14 @@ getResponseBody :: Result (Response ty) -> IO ty getResponseBody (Left err) = fail (show err) getResponseBody (Right r) = return (rspBody r)++-- | @getResponseBody response@ takes the response of a HTTP requesting action and+-- tries to extricate the status code of the 'Response' @response@. If the request action+-- returned an error, an IO exception is raised.+getResponseCode :: Result (Response ty) -> IO ResponseCode+getResponseCode (Left err) = fail (show err)+getResponseCode (Right r) = return (rspCode r)+ -- -- * TODO
Network/HTTP/Base.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base@@ -122,7 +123,7 @@ import Text.ParserCombinators.ReadP ( ReadP, readP_to_S, char, (<++), look, munch ) -import Control.Exception as Exception (IOException)+import Control.Exception as Exception (catch, IOException) import qualified Paths_cabal_install_bundle as Self (version) import Data.Version (showVersion)@@ -886,10 +887,10 @@ -- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific -- tweaks better go here. catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO a h = Prelude.catch a h+catchIO a h = Exception.catch a h catchIO_ :: IO a -> IO a -> IO a-catchIO_ a h = Prelude.catch a (const h)+catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) responseParseError :: String -> String -> Result a responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))
Network/HTTP/HandleStream.hs view
@@ -43,6 +43,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) -----------------------------------------------------------------@@ -88,8 +89,8 @@ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -112,9 +113,11 @@ --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (buf_fromStr bufferOps $ show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst@@ -150,7 +153,8 @@ Retry -> do {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- writeBlock conn ((buf_append bufferOps)+ -- TODO review throwing away of result+ _ <- writeBlock conn ((buf_append bufferOps) (buf_fromStr bufferOps (show rqst)) (rqBody rqst)) rsp <- getResponseHead conn@@ -228,9 +232,11 @@ -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = do - writeBlock conn (buf_fromStr bufferOps $ show rsp)+ -- TODO: review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)+ -- TODO: review throwing away of result+ _ <- writeBlock conn (rspBody rsp) return () ------------------------------------------------------------------------------
Network/HTTP/Proxy.hs view
@@ -21,6 +21,7 @@ import Control.Monad ( when, mplus, join, liftM2) +import Network.HTTP.Base ( catchIO ) import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI@@ -85,7 +86,7 @@ -- read proxy settings from the windows registry; this is just a best -- effort and may not work on all setups. -registryProxyString = Prelude.catch+registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable@@ -163,7 +164,9 @@ #if defined(WIN32) regQueryValueDWORD :: HKEY -> String -> IO DWORD regQueryValueDWORD hkey name = alloca $ \ptr -> do- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ -- TODO: this throws away the key type returned by regQueryValueEx+ -- we should check it's what we expect instead+ _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) peek ptr #endif
Network/HTTP/Stream.hs view
@@ -49,6 +49,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) @@ -86,8 +87,8 @@ sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -106,9 +107,11 @@ --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst@@ -153,7 +156,8 @@ Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- do { writeBlock conn (show rqst ++ rqBody rqst)+ do { -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst } @@ -224,7 +228,9 @@ -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)+respondHTTP conn rsp = do -- TODO review throwing away of result+ _ <- writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rspBody rsp) return ()
Network/StreamSocket.hs view
@@ -36,7 +36,7 @@ import Network.HTTP.Base ( catchIO ) import Control.Monad (liftM) import Control.Exception as Exception (IOException)-import System.IO.Error (catch, isEOFError)+import System.IO.Error (isEOFError) -- | Exception handler for socket operations. handleSocketError :: Socket -> IOException -> IO (Result a)@@ -50,7 +50,7 @@ myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler+ in catchIO (recv sock len) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n
Network/TCP.hs view
@@ -58,6 +58,7 @@ import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent+import Control.Exception ( onException ) import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError )@@ -221,7 +222,7 @@ where withSocket action = do s <- socket AF_INET Stream 6- catchIO (action s) (\e -> sClose s >> ioError e)+ onException (action s) (sClose s) getHostAddr h = do catchIO (inet_addr uri) -- handles ascii IP numbers (\ _ -> do@@ -302,7 +303,7 @@ ConnClosed -> print "aa" >> return False _ | connEndPoint v == endPoint ->- catch (getPeerName (connSock v) >> return True) (const $ return False)+ catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool@@ -312,7 +313,7 @@ ConnClosed -> return False _ | connEndPoint v == endPoint ->- catch (getPeerName (connSock v) >> return True) (const $ return False)+ catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)@@ -364,18 +365,18 @@ modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) return (return a) _ -> do- Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)- (\ e -> + catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)+ (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b = - Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ()))- (\ e -> return (failMisc (show e)))+ catchIO (buf_hPut ops h b >> hFlush h >> return (return ()))+ (\ e -> return (failMisc (show e))) bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do@@ -385,13 +386,13 @@ let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl))- _ -> Prelude.catch + _ -> catchIO (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where
cabal-install-bundle.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-bundle-Version: 0.14.0+Version: 0.16.0.2 Synopsis: The (bundled) command-line interface for Cabal and Hackage. Description: This is cabal-install with bundled dependencies. Easier to bootstrap. License: BSD3@@ -16,7 +16,7 @@ include/HsNetworkConfig.h.in include/HsNet.h -- C sources only used on some systems cbits/ancilData.c cbits/asyncAccept.c cbits/initWinSock.c- cbits/winSockErr.c+ cbits/winSockErr.c cbits/getnumcores.c cbits/crc32.h cbits/inffast.h cbits/inflate.h cbits/trees.h cbits/deflate.h cbits/inffixed.h cbits/inftrees.h cbits/zutil.h@@ -196,7 +196,7 @@ Distribution.Compat.FilePerms Paths_cabal_install_bundle - build-depends: base >= 2 && < 99, Cabal >= 1.14, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix+ build-depends: base >= 2 && < 99, Cabal >= 1.16, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix extensions: CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances, ExistentialQuantification, PolymorphicComponents, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, FunctionalDependencies
+ cbits/getnumcores.c view
@@ -0,0 +1,46 @@+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612)+/* 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 */