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 @@ -51,7 +51,11 @@ } case rspCode response of (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location +#if MIN_VERSION_network(2,4,0) + return $ relativeTo rel uri +#else relativeTo rel uri +#endif | Header HdrLocation location <- rspHeaders response ] -> return $ buildId _ -> error "Unrecognised response from server." @@ -61,7 +65,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 @@ -36,6 +36,8 @@ , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo ) +import Distribution.Client.Utils + ( numberOfProcessors ) import Distribution.Simple.Compiler ( OptimisationLevel(..) ) @@ -93,6 +95,8 @@ ( getEnvironment ) import System.IO.Error ( isDoesNotExistError ) +import Distribution.Compat.Exception + ( catchIO ) -- -- * Configuration saved in the config file @@ -198,7 +202,8 @@ }, savedInstallFlags = mempty { installSummaryFile = [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag AnonymousReports + installBuildReports= toFlag AnonymousReports, + installNumJobs = toFlag (Just numberOfProcessors) } } @@ -291,7 +296,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) @@ -105,7 +105,8 @@ (configDistPref configFlags), useLoggingHandle = Nothing, useWorkingDir = Nothing, - forceExternalSetupMethod = False + forceExternalSetupMethod = False, + setupCacheLock = Nothing } where -- Hack: we typically want to allow the UserPackageDB for finding the @@ -137,7 +138,8 @@ localPkg = SourcePackage { packageInfoId = packageId pkg, Source.packageDescription = pkg, - packageSource = LocalUnpackedPackage "." + packageSource = LocalUnpackedPackage ".", + packageDescrOverride = Nothing } testsEnabled = fromFlagOrDefault False $ configTests configFlags @@ -193,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/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) 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/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -18,8 +18,8 @@ import Network.Stream ( Result, ConnError(..) ) import Network.Browser - ( Proxy (..), Authority(..), BrowserAction, browse, setAllowBasicAuth, setAuthorityGen - , setOutHandler, setErrHandler, setProxy, request) + ( Proxy (..), Authority (..), BrowserAction, browse + , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) import Control.Monad ( mplus, join, liftM, liftM2 ) import qualified Data.ByteString.Lazy.Char8 as ByteString @@ -153,10 +153,10 @@ -- |Carry out a GET request, using the local proxy settings getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $ - cabalBrowse verbosity Nothing (request (mkRequest uri)) + cabalBrowse verbosity (return ()) (request (mkRequest uri)) cabalBrowse :: Verbosity - -> Maybe (String, String) + -> BrowserAction s () -> BrowserAction s a -> IO a cabalBrowse verbosity auth act = do @@ -165,8 +165,8 @@ setProxy p setErrHandler (warn verbosity . ("http error: "++)) setOutHandler (debug verbosity) - setAllowBasicAuth False - setAuthorityGen (\_ _ -> return auth) + auth + setAuthorityGen (\_ _ -> return Nothing) act downloadURI :: Verbosity 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 () @@ -342,7 +340,8 @@ ++ [ 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 (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 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 ) @@ -93,9 +95,9 @@ , 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 ) @@ -114,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 @@ -732,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 @@ -746,27 +752,31 @@ else newSerialJobControl buildLimit <- newJobLimit numJobs fetchLimit <- newJobLimit (min numJobs numFetchJobs) - installLimit <- newJobLimit 1 --serialise installation + installLock <- newLock -- serialise installation + cacheLock <- newLock -- serialise access to setup exe cache - executeInstallPlan verbosity jobControl installPlan $ \cpkg -> + executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags - cpkg $ \configFlags' src pkg -> + cpkg $ \configFlags' src pkg pkgoverride -> fetchSourcePackage verbosity fetchLimit src $ \src' -> installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath -> - installUnpackedPackage verbosity buildLimit installLimit - (setupScriptOptions installedPkgIndex) + 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 - numJobs = fromFlag (installNumJobs installFlags) + numJobs = case installNumJobs installFlags of + Cabal.NoFlag -> 1 + Cabal.Flag Nothing -> numberOfProcessors + Cabal.Flag (Just n) -> n numFetchJobs = 2 parallelBuild = numJobs >= 2 - setupScriptOptions index = SetupScriptOptions { + setupScriptOptions index lock = SetupScriptOptions { useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), useCompiler = Just comp, -- Hack: we typically want to allow the UserPackageDB for finding the @@ -787,25 +797,55 @@ (configDistPref configFlags), useLoggingHandle = Nothing, useWorkingDir = Nothing, - forceExternalSetupMethod = parallelBuild + 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. @@ -816,10 +856,11 @@ executeInstallPlan :: Verbosity -> JobControl IO (PackageId, BuildResult) + -> UseLogFile -> InstallPlan -> (ConfiguredPackage -> IO BuildResult) -> IO InstallPlan -executeInstallPlan verbosity jobCtl plan0 installPkg = +executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg = tryNewTasks 0 plan0 where tryNewTasks taskCount plan = do @@ -828,7 +869,7 @@ | otherwise -> waitForTasks taskCount plan pkgs -> do sequence_ - [ do notice verbosity $ "Ready to install " ++ display pkgid + [ do info verbosity $ "Ready to install " ++ display pkgid spawnJob jobCtl $ do buildResult <- installPkg pkg return (packageId pkg, buildResult) @@ -840,13 +881,14 @@ waitForTasks taskCount' plan' waitForTasks taskCount plan = do - notice verbosity $ "Waiting for install task to finish..." + info verbosity $ "Waiting for install task to finish..." (pkgid, buildResult) <- collectJob jobCtl - notice verbosity $ "Collecting build result for " ++ display pkgid + 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 @@ -859,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 @@ -869,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) @@ -955,7 +1019,8 @@ installUnpackedPackage :: Verbosity -> JobLimit - -> JobLimit + -> Lock + -> Int -> SetupScriptOptions -> InstallMisc -> ConfigFlags @@ -963,20 +1028,36 @@ -> HaddockFlags -> CompilerId -> PackageDescription + -> PackageDescriptionOverride -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) + -> UseLogFile -- ^ File to log output to (if any) -> IO BuildResult -installUnpackedPackage verbosity buildLimit installLimit +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 $ 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 @@ -996,7 +1077,7 @@ | otherwise = TestsNotTried -- Install phase - onFailure InstallFailed $ withJobLimit installLimit $ + onFailure InstallFailed $ criticalSection installLock $ withWin32SelfUpgrade verbosity configFlags compid pkg $ do case rootCmd miscOptions of (Just cmd) -> reexec cmd @@ -1004,6 +1085,7 @@ return (Right (BuildOk docsResult testsResult)) where + pkgid = packageId pkg configureFlags = filterConfigureFlags configFlags { configVerbosity = toFlag verbosity' } @@ -1022,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/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/JobControl.hs b/Distribution/Client/JobControl.hs --- a/Distribution/Client/JobControl.hs +++ b/Distribution/Client/JobControl.hs @@ -20,14 +20,16 @@ JobLimit, newJobLimit, withJobLimit, + + Lock, + newLock, + criticalSection ) where import Control.Monad import Control.Concurrent import Control.Exception -import Prelude hiding (catch) - data JobControl m a = JobControl { spawnJob :: m a -> m (), collectJob :: m a @@ -77,3 +79,11 @@ withJobLimit :: JobLimit -> IO a -> IO a withJobLimit (JobLimit sem) = bracket_ (waitQSem sem) (signalQSem sem) + +newtype Lock = Lock (MVar ()) + +newLock :: IO Lock +newLock = fmap Lock $ newMVar () + +criticalSection :: Lock -> IO a -> IO a +criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 @@ -616,7 +625,7 @@ installBuildReports :: Flag ReportLevel, installSymlinkBinDir :: Flag FilePath, installOneShot :: Flag Bool, - installNumJobs :: Flag Int + installNumJobs :: Flag (Maybe Int) } defaultInstallFlags :: InstallFlags @@ -640,7 +649,7 @@ installBuildReports = Flag NoReports, installSymlinkBinDir = mempty, installOneShot = Flag False, - installNumJobs = Flag 1 + installNumJobs = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") @@ -792,9 +801,11 @@ , option "j" ["jobs"] "Run NUM jobs simultaneously." installNumJobs (\v flags -> flags { installNumJobs = v }) - (reqArg "NUM" (readP_to_E (\_ -> "jobs should be a number") - (fmap toFlag (Parse.readS_to_P reads))) - (map show . flagToList)) + (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"] 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 ) 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 ) @@ -84,7 +89,11 @@ useDistPref :: FilePath, useLoggingHandle :: Maybe Handle, useWorkingDir :: Maybe FilePath, - forceExternalSetupMethod :: Bool + 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 @@ -97,7 +106,8 @@ useDistPref = defaultDistPref, useLoggingHandle = Nothing, useWorkingDir = Nothing, - forceExternalSetupMethod = False + forceExternalSetupMethod = False, + setupCacheLock = Nothing } setupWrapper :: Verbosity @@ -182,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 @@ -191,7 +203,6 @@ dir -> dir setupDir = workingDir useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" - setupProgFile = setupDir "setup" <.> exeExtension cabalLibVersionToUse :: IO (Version, SetupScriptOptions) cabalLibVersionToUse = do @@ -205,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 @@ -279,51 +290,99 @@ 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 + 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 @@ -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/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -15,10 +15,12 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.Browser - ( request ) + ( BrowserAction, request + , Authority(..), addAuthority ) import Network.HTTP ( Header(..), HeaderName(..), findHeader , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) import Network.URI (URI(uriPath), parseURI) import Data.Char (intToDigit) @@ -49,7 +51,12 @@ else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } flip mapM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " handlePackage verbosity uploadURI auth path @@ -75,9 +82,17 @@ report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () report verbosity repos mUsername mPassword = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = ""} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } forM_ repos $ \repo -> case repoKind repo of Left remoteRepo -> do dotCabal <- defaultCabalDir @@ -96,14 +111,16 @@ cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () Right{} -> return () + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given check :: Verbosity -> [FilePath] -> IO () check verbosity paths = do flip mapM_ paths $ \path -> do notice verbosity $ "Checking " ++ path ++ "... " - handlePackage verbosity checkURI Nothing path + handlePackage verbosity checkURI (return ()) path -handlePackage :: Verbosity -> URI -> Maybe (String, String) +handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) () -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path 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/Distribution/Compat/Time.hs b/Distribution/Compat/Time.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Time.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +module Distribution.Compat.Time where + +import Data.Int (Int64) +import System.Directory (getModificationTime) + +#if MIN_VERSION_directory(1,2,0) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength) +import Data.Time (getCurrentTime, diffUTCTime) +#else +import System.Time (ClockTime(..), getClockTime, diffClockTimes, normalizeTimeDiff, tdDay) +#endif + +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 + +getModTime :: FilePath -> IO EpochTime +getModTime path = do +#if MIN_VERSION_directory(1,2,0) + (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path +#else + (TOD s _) <- getModificationTime path + return $! fromIntegral s +#endif + +-- | Return age of given file in days. +getFileAge :: FilePath -> IO Int +getFileAge file = do + t0 <- getModificationTime file +#if MIN_VERSION_directory(1,2,0) + t1 <- getCurrentTime + let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength +#else + t1 <- getClockTime + let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0) +#endif + return days 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/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -47,16 +47,16 @@ # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.2"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* -DEEPSEQ_VER="1.3.0.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 -TEXT_VER="0.11.2.0"; TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12 -NETWORK_VER="2.3.0.11"; NETWORK_VER_REGEXP="2\." # == 2.* -CABAL_VER="1.14.0"; CABAL_VER_REGEXP="1\.(13\.3|14\.)" # >= 1.13.3 && < 1.15 +PARSEC_VER="3.1.3"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* +DEEPSEQ_VER="1.3.0.1"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 +TEXT_VER="0.11.2.3"; TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12 +NETWORK_VER="2.3.1.0"; NETWORK_VER_REGEXP="2\." # == 2.* +CABAL_VER="1.16.0"; CABAL_VER_REGEXP="1\.(13\.3|1[4-7]\.)" # >= 1.13.3 && < 1.18 TRANS_VER="0.3.0.0"; TRANS_VER_REGEXP="0\.[23]\." # >= 0.2.* && < 0.4.* -MTL_VER="2.1"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* -HTTP_VER="4000.2.3"; HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.* -ZLIB_VER="0.5.3.3"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.* -TIME_VER="1.4" TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5 +MTL_VER="2.1.2"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* +HTTP_VER="4000.2.4"; HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.* +ZLIB_VER="0.5.4.0"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.* +TIME_VER="1.4.0.1" TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5 RANDOM_VER="1.0.1.1" RANDOM_VER_REGEXP="1\.0\." # >= 1 && < 1.1 HACKAGE_URL="http://hackage.haskell.org/packages/archive" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,12 +1,12 @@ Name: cabal-install -Version: 0.14.1 +Version: 1.16.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. homepage: http://www.haskell.org/cabal/ -bug-reports: http://hackage.haskell.org/trac/hackage/ +bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE Author: Lemmih @@ -86,7 +86,7 @@ Distribution.Client.Install Distribution.Client.InstallPlan Distribution.Client.InstallSymlink - Distribution.Client.JobControl + Distribution.Client.JobControl Distribution.Client.List Distribution.Client.PackageIndex Distribution.Client.PackageUtils @@ -104,12 +104,13 @@ Distribution.Client.Win32SelfUpgrade Distribution.Compat.Exception Distribution.Compat.FilePerms + Distribution.Compat.Time Paths_cabal_install build-depends: base >= 2 && < 5, - Cabal >= 1.14.0 && < 1.15, + Cabal >= 1.16.0 && < 1.18, filepath >= 1.0 && < 1.4, - network >= 1 && < 2.4, + network >= 1 && < 3, HTTP >= 4000.0.2 && < 4001, zlib >= 0.4 && < 0.6, time >= 1.1 && < 1.5, @@ -120,10 +121,10 @@ else build-depends: base >= 3, process >= 1 && < 1.2, - directory >= 1 && < 1.2, + directory >= 1 && < 1.3, pretty >= 1 && < 1.2, random >= 1 && < 1.1, - containers >= 0.1 && < 0.5, + containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5, old-time >= 1 && < 1.2 @@ -136,5 +137,6 @@ build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 else - build-depends: unix >= 1.0 && < 2.6 - extensions: CPP + build-depends: unix >= 1.0 && < 2.7 + extensions: CPP, ForeignFunctionInterface + c-sources: cbits/getnumcores.c 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 */