diff --git a/Control/Monad/Error/Class.hs b/Control/Monad/Error/Class.hs --- a/Control/Monad/Error/Class.hs +++ b/Control/Monad/Error/Class.hs @@ -5,6 +5,7 @@ Copyright : (c) Michael Weber 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 diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -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"), diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -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 diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs --- a/Distribution/Client/Dependency/Modular/Assignment.hs +++ b/Distribution/Client/Dependency/Modular/Assignment.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs --- a/Distribution/Client/Dependency/Modular/Builder.hs +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -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) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs --- a/Distribution/Client/Dependency/Modular/Explore.hs +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs --- a/Distribution/Client/Dependency/Modular/Index.hs +++ b/Distribution/Client/Dependency/Modular/Index.hs @@ -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. diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs --- a/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -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, diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs --- a/Distribution/Client/Dependency/Modular/Log.hs +++ b/Distribution/Client/Dependency/Modular/Log.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs --- a/Distribution/Client/Dependency/Modular/Message.hs +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs --- a/Distribution/Client/Dependency/Modular/Preference.hs +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -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'. -- diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs --- a/Distribution/Client/Dependency/Modular/Solver.hs +++ b/Distribution/Client/Dependency/Modular/Solver.hs @@ -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": diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs --- a/Distribution/Client/Dependency/Modular/Tree.hs +++ b/Distribution/Client/Dependency/Modular/Tree.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs --- a/Distribution/Client/Dependency/Modular/Validate.hs +++ b/Distribution/Client/Dependency/Modular/Validate.hs @@ -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 diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -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) diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -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) diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -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 diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs --- a/Distribution/Client/Init/Licenses.hs +++ b/Distribution/Client/Init/Licenses.hs @@ -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." + ] diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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: diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -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 diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -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 diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -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 diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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 diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -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 diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -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 diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs --- a/Distribution/Client/Unpack.hs +++ b/Distribution/Client/Unpack.hs @@ -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) diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -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 diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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) diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -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) diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -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 diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -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)) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -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 () ------------------------------------------------------------------------------ diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -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 diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -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 () diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -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 diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -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 diff --git a/cabal-install-bundle.cabal b/cabal-install-bundle.cabal --- a/cabal-install-bundle.cabal +++ b/cabal-install-bundle.cabal @@ -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 diff --git a/cbits/getnumcores.c b/cbits/getnumcores.c new file mode 100644 --- /dev/null +++ b/cbits/getnumcores.c @@ -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 +#elif MACOS +#include +#include +#elif __linux__ +#include +#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 */