diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,307 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + new, + + -- * parsing and pretty printing + parse, + parseList, + show, + showList, + ) where + +import Distribution.Client.Types + ( ConfiguredPackage(..), BuildResult ) +import qualified Distribution.Client.Types as BR + ( BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import qualified Paths_cabal_install (version) + +import Distribution.Package + ( PackageIdentifier(PackageIdentifier), Package(packageId) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +--import Distribution.Version +-- ( Version ) +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId ) +import qualified Distribution.Text as Text + ( Text(disp, parse) ) +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), Field(..) + , simpleField, listField, ppFields, readFields + , syntaxError, locatedErrorMsg ) +import Distribution.Simple.Utils + ( comparing ) + +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, pfail, munch1, skipSpaces ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, char, text ) +import Text.PrettyPrint.HughesPJ + ( (<+>), (<>) ) + +import Data.List + ( unfoldr, sortBy ) +import Data.Char as Char + ( isAlpha, isAlphaNum ) + +import Prelude hiding (show) + +data BuildReport + = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + +data InstallOutcome + = DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | InstallFailed + | InstallOk + +data Outcome = NotTried | Failed | Ok + +new :: OS -> Arch -> CompilerId -- -> Version + -> ConfiguredPackage -> BR.BuildResult + -> BuildReport +new os' arch' comp (ConfiguredPackage pkg flags deps) result = + BuildReport { + package = packageId pkg, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + cabalInstallID = + PackageIdentifier "cabal-install" Paths_cabal_install.version + + convertInstallOutcome = case result of + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk BR.DocsNotTried _) -> NotTried + Right (BR.BuildOk BR.DocsFailed _) -> Failed + Right (BR.BuildOk BR.DocsOk _) -> Ok + convertTestsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried + Right (BR.BuildOk _ BR.TestsFailed) -> Failed + Right (BR.BuildOk _ BR.TestsOk) -> Ok + +-- ------------------------------------------------------------ +-- * External format +-- ------------------------------------------------------------ + +initialBuildReport :: BuildReport +initialBuildReport = BuildReport { + package = requiredField "package", + os = requiredField "os", + arch = requiredField "arch", + compiler = requiredField "compiler", + client = requiredField "client", + flagAssignment = [], + dependencies = [], + installOutcome = requiredField "install-outcome", +-- cabalVersion = Nothing, +-- tools = [], + docsOutcome = NotTried, + testsOutcome = NotTried + } + where + requiredField fname = error ("required field: " ++ fname) + +-- ----------------------------------------------------------------------------- +-- Parsing + +parse :: String -> Either String BuildReport +parse s = case parseFields s of + ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror + ParseOk _ report -> Right report + +--FIXME: this does not allow for optional or repeated fields +parseFields :: String -> ParseResult BuildReport +parseFields input = do + fields <- mapM extractField =<< readFields input + let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) + sortedFieldDescrs + (sortBy (comparing (\(_,name,_) -> name)) fields) + checkMerged initialBuildReport merged + + where + extractField :: Field -> ParseResult (Int, String, String) + extractField (F line name value) = return (line, name, value) + extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" + extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" + + checkMerged report [] = return report + checkMerged report (merged:remaining) = case merged of + InBoth fieldDescr (line, _name, value) -> do + report' <- fieldSet fieldDescr line value report + checkMerged report' remaining + OnlyInRight (line, name, _) -> + syntaxError line ("Unrecognized field " ++ name) + OnlyInLeft fieldDescr -> + fail ("Missing field " ++ fieldName fieldDescr) + +parseList :: String -> [BuildReport] +parseList str = + [ report | Right report <- map parse (split str) ] + + where + split :: String -> [String] + split = filter (not . null) . unfoldr chunk . lines + chunk [] = Nothing + chunk ls = case break null ls of + (r, rs) -> Just (unlines r, dropWhile null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +show :: BuildReport -> String +show br = Disp.render (ppFields br fieldDescrs) + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldDescrs :: [FieldDescr BuildReport] +fieldDescrs = + [ simpleField "package" Text.disp Text.parse + package (\v r -> r { package = v }) + , simpleField "os" Text.disp Text.parse + os (\v r -> r { os = v }) + , simpleField "arch" Text.disp Text.parse + arch (\v r -> r { arch = v }) + , simpleField "compiler" Text.disp Text.parse + compiler (\v r -> r { compiler = v }) + , simpleField "client" Text.disp Text.parse + client (\v r -> r { client = v }) + , listField "flags" dispFlag parseFlag + flagAssignment (\v r -> r { flagAssignment = v }) + , listField "dependencies" Text.disp Text.parse + dependencies (\v r -> r { dependencies = v }) + , simpleField "install-outcome" Text.disp Text.parse + installOutcome (\v r -> r { installOutcome = v }) + , simpleField "docs-outcome" Text.disp Text.parse + docsOutcome (\v r -> r { docsOutcome = v }) + , simpleField "tests-outcome" Text.disp Text.parse + testsOutcome (\v r -> r { testsOutcome = v }) + ] + +sortedFieldDescrs :: [FieldDescr BuildReport] +sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs + +dispFlag :: (FlagName, Bool) -> Disp.Doc +dispFlag (FlagName name, True) = Disp.text name +dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name + +parseFlag :: Parse.ReadP r (FlagName, Bool) +parseFlag = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + case name of + ('-':flag) -> return (FlagName flag, False) + flag -> return (FlagName flag, True) + +instance Text.Text InstallOutcome where + disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid + disp DownloadFailed = Disp.text "DownloadFailed" + disp UnpackFailed = Disp.text "UnpackFailed" + disp SetupFailed = Disp.text "SetupFailed" + disp ConfigureFailed = Disp.text "ConfigureFailed" + disp BuildFailed = Disp.text "BuildFailed" + disp InstallFailed = Disp.text "InstallFailed" + disp InstallOk = Disp.text "InstallOk" + + parse = do + name <- Parse.munch1 Char.isAlphaNum + case name of + "DependencyFailed" -> do Parse.skipSpaces + pkgid <- Text.parse + return (DependencyFailed pkgid) + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> Parse.pfail + +instance Text.Text Outcome where + disp NotTried = Disp.text "NotTried" + disp Failed = Disp.text "Failed" + disp Ok = Disp.text "Ok" + parse = do + name <- Parse.munch1 Char.isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> Parse.pfail diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,117 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + ) where + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +import Distribution.Client.Types + ( ConfiguredPackage(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan, PlanPackage ) +import Distribution.Client.Config + ( defaultLogsDir ) + +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( groupBy, sortBy ) +import Data.Maybe + ( catMaybes ) +import System.FilePath + ( () ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : BuildReport.show r ++ "\n" + separate :: [(BuildReport, Repo)] + -> [(Repo, [BuildReport])] + separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) + . map concat + . groupBy (equating (repoName . head)) + . sortBy (comparing (repoName . head)) + . groupBy (equating repoName) + . onlyRemote + repoName (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] + +storeLocal :: [(BuildReport, Repo)] -> IO () +storeLocal reports = do + logsDir <- defaultLogsDir + let file = logsDir "build.log" + createDirectoryIfMissing True logsDir + appendFile file (concatMap (format . fst) reports) + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : BuildReport.show r ++ "\n" + + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan plan = catMaybes + . map (fromPlanPackage os' arch' comp) + . InstallPlan.toList + $ plan + where os' = InstallPlan.planOS plan + arch' = InstallPlan.planArch plan + comp = InstallPlan.planCompiler plan + +fromPlanPackage :: OS -> Arch -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe (BuildReport, Repo) +fromPlanPackage os' arch' comp planPackage = case planPackage of + + InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo }) _ _) result + -> Just $ (BuildReport.new os' arch' comp pkg (Right result), repo) + + InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo }) _ _) result + -> Just $ (BuildReport.new os' arch' comp pkg (Left result), repo) + + _ -> Nothing diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + , postBuildReport + , putBuildLog + ) where + +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.URI (URI, uriPath, parseRelativeReference, relativeTo) + +import Control.Monad + ( forM_ ) +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] -> BrowserAction () +uploadReports uri reports + = forM_ reports $ \(report, mbBuildLog) -> + do buildId <- postBuildReport uri report + case mbBuildLog of + Just buildLog -> putBuildLog buildId buildLog + Nothing -> return () + +postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId +postBuildReport uri buildReport = do + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/buildreports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location + relativeTo rel uri + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport + +putBuildLog :: BuildReportId -> BuildLog -> BrowserAction () +putBuildLog reportId buildLog = do + --FIXME: do something if the request fails + (_, response) <- request Request { + rqURI = reportId{uriPath = uriPath reportId "buildlog"}, + rqMethod = PUT, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length buildLog)), + Header HdrAccept ("text/plain")], + rqBody = buildLog + } + return () diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Check.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + +import Control.Monad ( when, unless ) + +import Distribution.PackageDescription ( readPackageDescription ) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Utils ( defaultPackageDesc, toUTF8 ) + +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- Hovever, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + putStrLn "The package will not build sanely due to these errors:" + mapM_ (putStrLn . toUTF8. explanation) buildImpossible + putStrLn "" + + unless (null buildWarning) $ do + putStrLn "The following warnings are likely affect your build negatively:" + mapM_ (putStrLn . toUTF8 . explanation) buildWarning + putStrLn "" + + unless (null distSuspicious) $ do + putStrLn "These warnings may cause trouble when distributing the package:" + mapM_ (putStrLn . toUTF8 . explanation) distSuspicious + putStrLn "" + + unless (null distInexusable) $ do + putStrLn "The following errors will cause portability problems on other environments:" + mapM_ (putStrLn . toUTF8 . explanation) distInexusable + putStrLn "" + + let isDistError (PackageDistSuspicious {}) = False + isDistError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ do + putStrLn "Hackage would reject this package." + + when (null packageChecks) $ do + putStrLn "No errors or warnings could be found in the package." + + return (null packageChecks) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Config.hs @@ -0,0 +1,508 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + SavedConfig(..), + loadConfig, + + showConfig, + showConfigWithComments, + parseConfig, + + defaultCabalDir, + defaultCacheDir, + defaultLogsDir, + ) where + + +import Distribution.Client.Types + ( RemoteRepo(..), Username(..), Password(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , showRepo, parseRepo ) + +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.ParseUtils + ( FieldDescr(..), liftField + , ParseResult(..), locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, parseFilePathQ, parseTokenQ ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) +import Distribution.ReadE + ( succeedReadE ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) + , viewAsFieldDescr, OptionField, option, reqArg ) +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Utils + ( notice, warn, lowercase ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.List + ( partition ) +import Data.Maybe + ( fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( when, foldM ) +import qualified Data.Map as Map +import qualified Distribution.Compat.ReadP as Parse + ( option ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, text, colon, vcat, isEmpty, nest ) +import Text.PrettyPrint.HughesPJ + ( (<>), (<+>), ($$), ($+$) ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory ) +import Network.URI + ( URI(..), URIAuth(..) ) +import System.FilePath + ( (), takeDirectory ) +import System.IO.Error + ( isDoesNotExistError ) + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig { + savedGlobalFlags :: GlobalFlags, + savedInstallFlags :: InstallFlags, + savedConfigureFlags :: ConfigFlags, + savedUserInstallDirs :: InstallDirs (Flag PathTemplate), + savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), + savedUploadFlags :: UploadFlags + } + +instance Monoid SavedConfig where + mempty = SavedConfig { + savedGlobalFlags = mempty, + savedInstallFlags = mempty, + savedConfigureFlags = mempty, + savedUserInstallDirs = mempty, + savedGlobalInstallDirs = mempty, + savedUploadFlags = mempty + } + mappend a b = SavedConfig { + savedGlobalFlags = combine savedGlobalFlags, + savedInstallFlags = combine savedInstallFlags, + savedConfigureFlags = combine savedConfigureFlags, + savedUserInstallDirs = combine savedUserInstallDirs, + savedGlobalInstallDirs = combine savedGlobalInstallDirs, + savedUploadFlags = combine savedUploadFlags + } + where combine field = field a `mappend` field b + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag + savedConfig@SavedConfig { + savedConfigureFlags = configureFlags, + savedUserInstallDirs = userInstallDirs, + savedGlobalInstallDirs = globalInstallDirs + } = + savedConfig { + savedConfigureFlags = configureFlags { + configInstallDirs = installDirs + } + } + where + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall $ + configUserInstall configureFlags `mappend` userInstallFlag + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- defaultCabalDir + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + } + } + +-- | This is the initial configuration that we write out to to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = [defaultRemoteRepo] + } + } + +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- defaultCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- defaultCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- defaultCabalDir + return $ dir "logs" + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = case buildOS of + -- We do global installs by default on Windows + Windows -> False + -- and per-user installs by default everywhere else + _ -> True + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri + where + name = "hackage.haskell.org" + uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" "" + +-- +-- * Config file reading +-- + +loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig +loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do + configFile <- maybe defaultConfigFile return (flagToMaybe configFileFlag) + + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ "Config file " ++ configFile ++ " not found." + notice verbosity $ "Writing default configuration to " ++ configFile + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + writeConfigFile configFile commentConf initialConf + return initialConf + Just (ParseOk ws conf) -> do + when (not $ null ws) $ warn verbosity $ + unlines (map (showPWarning configFile) ws) + return conf + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + warn verbosity $ + "Error parsing config file " ++ configFile + ++ maybe "" (\n -> ":" ++ show n) line ++ ": " ++ show msg + warn verbosity $ "Using default configuration." + initialSavedConfig + + where + addBaseConf body = do + base <- baseSavedConfig + extra <- body + return (updateInstallDirs userInstallFlag (base `mappend` extra)) + +readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig initial) (readFile file) + + where + handleNotExists action = catch action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () +writeConfigFile file comments vals = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file $ showConfigWithComments comments vals ++ "\n" + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + return SavedConfig { + savedGlobalFlags = commandDefaultFlags globalCommand, + savedInstallFlags = defaultInstallFlags, + savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand + } + +-- | All config file fields. +-- +configFieldDescriptions :: [FieldDescr SavedConfig] +configFieldDescriptions = + + toSavedConfig liftGlobalFlag + (commandOptions globalCommand ParseArgs) + ["version", "numeric-version", "config-file"] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "reinstall", "only"] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["scratchdir", "configure-option"] ++ map fieldName installDirsFields) + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check"] + + where + toSavedConfig lift options excluded = + [ lift field + | opt <- options + , let field = viewAsFieldDescr opt + , fieldName field `notElem` excluded ] + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listField "repos" + (Disp.text . showRepo) parseRepo + globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) + , liftGlobalFlag $ + simpleField "cachedir" + (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleField "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optional (fmap Username parseTokenQ)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleField "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optional (fmap Password parseTokenQ)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + where + optional = Parse.option mempty . fmap toFlag + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = liftField + savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +parseConfig :: SavedConfig -> String -> ParseResult SavedConfig +parseConfig initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + (user, global) <- foldM parseSections (mempty, mempty) knownSections + return config { + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse = parseFields (configFieldDescriptions + ++ deprecatedFieldDescriptions) initial + + parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (u', g) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (u, g') + | otherwise = do + warning "The install-paths section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + ppFields configFieldDescriptions comment vals + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + where + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (field comment) (field vals) + +------------------------ +-- * Parsing utils +-- + +--FIXME: replace this with something better in Cabal-1.5 +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields initial = foldM setField initial + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the function from Cabal that also prints +-- default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc +ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc +ppField name def cur + | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def + | otherwise = Disp.text name <> Disp.colon <+> cur + +ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) + +installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] +installDirsFields = map viewAsFieldDescr installDirsOptions + +--TODO: this is now exported in Cabal-1.5 +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + + reqArgFlag ad = reqArg ad (succeedReadE toFlag) flagToList diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency.hs @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + resolveDependencies, + resolveDependenciesWithProgress, + PackagesVersionPreference(..), + upgradableDependencies, + ) where + +import Distribution.Client.Dependency.Bogus (bogusResolver) +import Distribution.Client.Dependency.TopDown (topDownResolver) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) ) +import Distribution.Client.Dependency.Types + ( PackageName, DependencyResolver, PackageVersionPreference(..) + , Progress(..), foldProgress ) +import Distribution.Package + ( PackageIdentifier(..), packageVersion, packageName + , Dependency(..), Package(..), PackageFixedDeps(..) ) +import Distribution.Version + ( orLaterVersion ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( OS, Arch ) +import Distribution.Simple.Utils (comparing) +import Distribution.Client.Utils (mergeBy, MergeResult(..)) + +import Data.List (maximumBy) +import Data.Monoid (Monoid(mempty)) +import qualified Data.Set as Set +import Data.Set (Set) +import Control.Exception (assert) + +defaultResolver :: DependencyResolver +defaultResolver = topDownResolver +--for the brave: try the new topDownResolver, but only with --dry-run !!! + +-- | Global policy for the versions of all packages. +-- +data PackagesVersionPreference = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest available version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + +resolveDependencies :: OS + -> Arch + -> CompilerId + -> Maybe (PackageIndex InstalledPackageInfo) + -> PackageIndex AvailablePackage + -> PackagesVersionPreference + -> [UnresolvedDependency] + -> Either String InstallPlan +resolveDependencies os arch comp installed available pref deps = + foldProgress (flip const) Left Right $ + resolveDependenciesWithProgress os arch comp installed available pref deps + +resolveDependenciesWithProgress :: OS + -> Arch + -> CompilerId + -> Maybe (PackageIndex InstalledPackageInfo) + -> PackageIndex AvailablePackage + -> PackagesVersionPreference + -> [UnresolvedDependency] + -> Progress String String InstallPlan +resolveDependenciesWithProgress os arch comp (Just installed) = + dependencyResolver defaultResolver os arch comp installed + +resolveDependenciesWithProgress os arch comp Nothing = + dependencyResolver bogusResolver os arch comp mempty + +hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p +hideBrokenPackages index = + check (null . PackageIndex.brokenPackages) + . foldr (PackageIndex.deletePackageId . packageId) index + . PackageIndex.reverseDependencyClosure index + . map (packageId . fst) + $ PackageIndex.brokenPackages index + where + check p x = assert (p x) x + +hideBasePackage :: Package p => PackageIndex p -> PackageIndex p +hideBasePackage = PackageIndex.deletePackageName "base" + . PackageIndex.deletePackageName "ghc-prim" + +dependencyResolver + :: DependencyResolver + -> OS -> Arch -> CompilerId + -> PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> PackagesVersionPreference + -> [UnresolvedDependency] + -> Progress String String InstallPlan +dependencyResolver resolver os arch comp installed available pref deps = + let installed' = hideBrokenPackages installed + available' = hideBasePackage available + in fmap toPlan + $ resolver os arch comp installed' available' preference deps + + where + toPlan pkgs = + case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of + Right plan -> plan + Left problems -> error $ unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : map InstallPlan.showPlanProblem problems + + preference = interpretPackagesVersionPreference initialPkgNames pref + initialPkgNames = Set.fromList + [ name | UnresolvedDependency (Dependency name _) _ <- deps ] + +-- | Give an interpretation to the global 'PackagesVersionPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesVersionPreference :: Set PackageName + -> PackagesVersionPreference + -> (PackageName -> PackageVersionPreference) +interpretPackagesVersionPreference selected pref = case pref of + PreferAllLatest -> const PreferLatest + PreferAllInstalled -> const PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else: + if pkgname `Set.member` selected + then PreferLatest + else PreferInstalled + +-- | Given the list of installed packages and available packages, figure +-- out which packages can be upgraded. +-- +upgradableDependencies :: PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> [Dependency] +upgradableDependencies installed available = + [ Dependency name (orLaterVersion latestVersion) + -- This is really quick (linear time). The trick is that we're doing a + -- merge join of two tables. We can do it as a merge because they're in + -- a comparable order because we're getting them from the package indexs. + | InBoth latestInstalled allAvailable + <- mergeBy (\a (b:_) -> packageName a `compare` packageName b) + [ maximumBy (comparing packageVersion) pkgs + | pkgs <- PackageIndex.allPackagesByName installed ] + (PackageIndex.allPackagesByName available) + , let (PackageIdentifier name latestVersion) = packageId latestInstalled + , any (\p -> packageVersion p > latestVersion) allAvailable ] diff --git a/Distribution/Client/Dependency/Bogus.hs b/Distribution/Client/Dependency/Bogus.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Bogus.hs @@ -0,0 +1,109 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Bogus +-- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A dependency resolver for when we do not know what packages are installed. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Bogus ( + bogusResolver + ) where + +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) + , ConfiguredPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, Progress(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.Package + ( PackageIdentifier(..), Dependency(..), Package(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Version + ( VersionRange(IntersectVersionRanges) ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( maximumBy, sortBy, groupBy ) + +-- | This resolver thinks that every package is already installed. +-- +-- We need this for hugs and nhc98 which do not track installed packages. +-- We just pretend that everything is installed and hope for the best. +-- +bogusResolver :: DependencyResolver +bogusResolver os arch comp _ available _ = resolveFromAvailable [] + . combineDependencies + where + resolveFromAvailable chosen [] = Done chosen + resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) = + case latestAvailableSatisfying available dep of + Nothing -> Fail ("Unresolved dependency: " ++ display dep) + Just apkg@(AvailablePackage _ pkg _) -> + case finalizePackageDescription flags none os arch comp [] pkg of + Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps) + where + msg = "selecting " ++ display (packageId pkg) + cpkg = fudgeChosenPackage apkg flags' + chosen' = InstallPlan.Configured cpkg : chosen + _ -> error "bogusResolver: impossible happened" + where + none :: Maybe (PackageIndex PackageIdentifier) + none = Nothing + +fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage +fudgeChosenPackage (AvailablePackage pkgid pkg source) flags = + ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source) + flags ([] :: [PackageIdentifier]) -- empty list of deps + where + -- | Pretend that a package has no dependencies. Go through the + -- 'GenericPackageDescription' and strip them all out. + -- + stripDependencies :: GenericPackageDescription -> GenericPackageDescription + stripDependencies gpkg = gpkg { + condLibrary = fmap stripDeps (condLibrary gpkg), + condExecutables = [ (name, stripDeps tree) + | (name, tree) <- condExecutables gpkg ] + } + stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a + stripDeps = mapTreeConstrs (const []) + + mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a + mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs) + where + g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me) + +combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency] +combineDependencies = map combineGroup + . groupBy (equating depName) + . sortBy (comparing depName) + where + combineGroup deps = UnresolvedDependency (Dependency name ver) flags + where name = depName (head deps) + ver = foldr1 IntersectVersionRanges . map depVer $ deps + flags = concatMap depFlags deps + depName (UnresolvedDependency (Dependency name _) _) = name + depVer (UnresolvedDependency (Dependency _ ver) _) = ver + +-- | Gets the latest available package satisfying a dependency. +latestAvailableSatisfying :: PackageIndex AvailablePackage + -> Dependency + -> Maybe AvailablePackage +latestAvailableSatisfying index dep = + case PackageIndex.lookupDependency index dep of + [] -> Nothing + pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs) diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown.hs @@ -0,0 +1,598 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown ( + topDownResolver + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints +import Distribution.Client.Dependency.TopDown.Constraints + ( Satisfiable(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( PlanPackage(..) ) +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) + , ConfiguredPackage(..) ) +import Distribution.Client.Dependency.Types + ( PackageName, DependencyResolver, PackageVersionPreference(..) + , Progress(..), foldProgress ) + +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Package + ( PackageIdentifier, Package(packageId), packageVersion, packageName + , Dependency(Dependency), thisPackageVersion, notThisPackageVersion + , PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( PackageDescription(buildDepends) ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( OS, Arch ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( foldl', maximumBy, minimumBy, deleteBy, nub, sort ) +import Data.Maybe + ( fromJust, fromMaybe ) +import Data.Monoid + ( Monoid(mempty) ) +import Control.Monad + ( guard ) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Graph as Graph +import qualified Data.Array as Array + +-- ------------------------------------------------------------ +-- * Search state types +-- ------------------------------------------------------------ + +type Constraints = Constraints.Constraints + InstalledPackage UnconfiguredPackage ExclusionReason +type SelectedPackages = PackageIndex SelectedPackage + +-- ------------------------------------------------------------ +-- * The search tree type +-- ------------------------------------------------------------ + +data SearchSpace inherited pkg + = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] + | Failure Failure + +-- ------------------------------------------------------------ +-- * Traverse a search tree +-- ------------------------------------------------------------ + +explore :: (PackageName -> PackageVersionPreference) + -> SearchSpace a SelectablePackage + -> Progress Log Failure a + +explore _ (Failure failure) = Fail failure +explore _explore (ChoiceNode result []) = Done result +explore pref (ChoiceNode _ choices) = + case [ choice | [choice] <- choices ] of + ((pkg, node'):_) -> Step (Select pkg []) (explore pref node') + [] -> seq pkgs' -- avoid retaining defaultChoice + $ Step (Select pkg pkgs') (explore pref node') + where + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (pkg, node') = maximumBy (bestByPref pkgname) choice + pkgs' = deleteBy (equating packageId) pkg (map fst choice) + + where + topSortNumber choice = case fst (head choice) of + InstalledOnly (InstalledPackage _ i _) -> i + AvailableOnly (UnconfiguredPackage _ i _) -> i + InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i + + bestByPref pkgname = case pref pkgname of + PreferLatest -> comparing (\(p,_) -> packageId p) + PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p)) + where isInstalled (AvailableOnly _) = False + isInstalled _ = True + +-- ------------------------------------------------------------ +-- * Generate a search tree +-- ------------------------------------------------------------ + +type ConfigurePackage = PackageIndex SelectablePackage + -> SelectablePackage + -> Either [Dependency] SelectedPackage + +searchSpace :: ConfigurePackage + -> Constraints + -> SelectedPackages + -> Set PackageName + -> SearchSpace (SelectedPackages, Constraints) SelectablePackage +searchSpace configure constraints selected next = + ChoiceNode (selected, constraints) + [ [ (pkg, select name pkg) + | pkg <- PackageIndex.lookupPackageName available name ] + | name <- Set.elems next ] + where + available = Constraints.choices constraints + + select name pkg = case configure available pkg of + Left missing -> Failure $ ConfigureFailed pkg + [ (dep, Constraints.conflicting constraints dep) + | dep <- missing ] + Right pkg' -> + let selected' = PackageIndex.insert pkg' selected + newPkgs = [ name' + | dep <- packageConstraints pkg' + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = packageConstraints pkg' + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + in case constrainDeps pkg' newDeps constraints of + Left failure -> Failure failure + Right constraints' -> searchSpace configure + constraints' selected' next' + +packageConstraints :: SelectedPackage -> [TaggedDependency] +packageConstraints = either installedConstraints availableConstraints + . preferAvailable + where + preferAvailable (InstalledOnly pkg) = Left pkg + preferAvailable (AvailableOnly pkg) = Right pkg + preferAvailable (InstalledAndAvailable _ pkg) = Right pkg + installedConstraints (InstalledPackage _ _ deps) = + [ TaggedDependency InstalledConstraint (thisPackageVersion dep) + | dep <- deps ] + availableConstraints (SemiConfiguredPackage _ _ deps) = + [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] + +constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints + -> Either Failure Constraints +constrainDeps pkg [] cs = + case addPackageSelectConstraint (packageId pkg) cs of + Satisfiable cs' -> Right cs' + _ -> impossible +constrainDeps pkg (dep:deps) cs = + case addPackageDependencyConstraint (packageId pkg) dep cs of + Satisfiable cs' -> constrainDeps pkg deps cs' + Unsatisfiable -> impossible + ConflictsWith conflicts -> + Left (DependencyConflict pkg dep conflicts) + +-- ------------------------------------------------------------ +-- * The main algorithm +-- ------------------------------------------------------------ + +search :: ConfigurePackage + -> (PackageName -> PackageVersionPreference) + -> Constraints + -> Set PackageName + -> Progress Log Failure (SelectedPackages, Constraints) +search configure pref constraints = + explore pref . searchSpace configure constraints mempty + +-- ------------------------------------------------------------ +-- * The top level resolver +-- ------------------------------------------------------------ + +-- | The main exported resolver, with string logging and failure types to fit +-- the standard 'DependencyResolver' interface. +-- +topDownResolver :: DependencyResolver +topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' + where + mapMessages :: Progress Log Failure a -> Progress String String a + mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done + +-- | The native resolver with detailed structured logging and failure types. +-- +topDownResolver' :: OS -> Arch -> CompilerId + -> PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> (PackageName -> PackageVersionPreference) + -> [UnresolvedDependency] + -> Progress Log Failure [PlanPackage] +topDownResolver' os arch comp installed available pref deps = + fmap (uncurry finalise) + . (\cs -> search configure pref cs initialPkgNames) + =<< constrainTopLevelDeps deps constraints + + where + configure = configurePackage os arch comp + constraints = Constraints.empty + (annotateInstalledPackages topSortNumber installed') + (annotateAvailablePackages deps topSortNumber available') + (installed', available') = selectNeededSubset installed available + initialPkgNames + topSortNumber = topologicalSortNumbering installed' available' + + initialDeps = [ dep | UnresolvedDependency dep _ <- deps ] + initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ] + + finalise selected = PackageIndex.allPackages + . improvePlan installed' + . PackageIndex.fromList + . finaliseSelectedPackages selected + +constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints + -> Progress a Failure Constraints +constrainTopLevelDeps [] cs = Done cs +constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs = + case addTopLevelDependencyConstraint dep cs of + Satisfiable cs' -> constrainTopLevelDeps deps cs' + Unsatisfiable -> Fail (TopLevelDependencyUnsatisfiable dep) + ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts) + +configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage +configurePackage os arch comp available spkg = case spkg of + InstalledOnly ipkg -> Right (InstalledOnly ipkg) + AvailableOnly apkg -> fmap AvailableOnly (configure apkg) + InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg) + (configure apkg) + where + configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = + case finalizePackageDescription flags (Just available) os arch comp [] p of + Left missing -> Left missing + Right (pkg, flags') -> Right $ + SemiConfiguredPackage apkg flags' (buildDepends pkg) + +-- | Annotate each installed packages with its set of transative dependencies +-- and its topological sort number. +-- +annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) + -> PackageIndex InstalledPackageInfo + -> PackageIndex InstalledPackage +annotateInstalledPackages dfsNumber installed = PackageIndex.fromList + [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + | pkg <- PackageIndex.allPackages installed ] + where + transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier] + transitiveDepends = map toPkgid . tail . Graph.reachable graph + . fromJust . toVertex . packageId + (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed + + +-- | Annotate each available packages with its topological sort number and any +-- user-supplied partial flag assignment. +-- +annotateAvailablePackages :: [UnresolvedDependency] + -> (PackageName -> TopologicalSortNumber) + -> PackageIndex AvailablePackage + -> PackageIndex UnconfiguredPackage +annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList + [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) + | pkg <- PackageIndex.allPackages available + , let name = packageName pkg ] + where + flagsFor = fromMaybe [] . flip Map.lookup flagsMap + flagsMap = Map.fromList + [ (name, flags) + | UnresolvedDependency (Dependency name _) flags <- deps ] + +-- | One of the heuristics we use when guessing which path to take in the +-- search space is an ordering on the choices we make. It's generally better +-- to make decisions about packages higer in the dep graph first since they +-- place constraints on packages lower in the dep graph. +-- +-- To pick them in that order we annotate each package with its topological +-- sort number. So if package A depends on package B then package A will have +-- a lower topological sort number than B and we'll make a choice about which +-- version of A to pick before we make a choice about B (unless there is only +-- one possible choice for B in which case we pick that immediately). +-- +-- To construct these topological sort numbers we combine and flatten the +-- installed and available package sets. We consider only dependencies between +-- named packages, not including versions and for not-yet-configured packages +-- we look at all the possible dependencies, not just those under any single +-- flag assignment. This means we can actually get impossible combinations of +-- edges and even cycles, but that doesn't really matter here, it's only a +-- heuristic. +-- +topologicalSortNumbering :: PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> (PackageName -> TopologicalSortNumber) +topologicalSortNumbering installed available = + \pkgname -> let Just vertex = toVertex pkgname + in topologicalSortNumbers Array.! vertex + where + topologicalSortNumbers = Array.array (Array.bounds graph) + (zip (Graph.topSort graph) [0..]) + (graph, _, toVertex) = Graph.graphFromEdges $ + [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed + , let deps = [ packageName dep + | pkg' <- pkgs + , dep <- depends pkg' ] ] + ++ [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available + , let deps = [ depName + | AvailablePackage _ pkg' _ <- pkgs + , Dependency depName _ <- + buildDepends (flattenPackageDescription pkg') ] ] + +-- | We don't need the entire index (which is rather large and costly if we +-- force it by examining the whole thing). So trace out the maximul subset of +-- each index that we could possibly ever need. Do this by flattening packages +-- and looking at the names of all possible dependencies. +-- +selectNeededSubset :: PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackageInfo + ,PackageIndex AvailablePackage) +selectNeededSubset installed available = select mempty mempty + where + select :: PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackageInfo + ,PackageIndex AvailablePackage) + select installed' available' remaining + | Set.null remaining = (installed', available') + | otherwise = select installed'' available'' remaining'' + where + (next, remaining') = Set.deleteFindMin remaining + moreInstalled = PackageIndex.lookupPackageName installed next + moreAvailable = PackageIndex.lookupPackageName available next + moreRemaining = nub + $ [ packageName dep + | pkg <- moreInstalled + , dep <- depends pkg ] + ++ [ name + | AvailablePackage _ pkg _ <- moreAvailable + , Dependency name _ <- + buildDepends (flattenPackageDescription pkg) ] + installed'' = foldr PackageIndex.insert installed' moreInstalled + available'' = foldr PackageIndex.insert available' moreAvailable + remaining'' = foldr Set.insert remaining' moreRemaining + +-- ------------------------------------------------------------ +-- * Post processing the solution +-- ------------------------------------------------------------ + +finaliseSelectedPackages :: SelectedPackages + -> Constraints + -> [PlanPackage] +finaliseSelectedPackages selected constraints = + map finaliseSelected (PackageIndex.allPackages selected) + where + remainingChoices = Constraints.choices constraints + finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg + finaliseSelected (AvailableOnly apkg) = finaliseAvailable apkg + finaliseSelected (InstalledAndAvailable ipkg apkg) = + case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of + Nothing -> impossible --picked package not in constraints + Just (AvailableOnly _) -> impossible --to constrain to avail only + Just (InstalledOnly _) -> finaliseInstalled ipkg + Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg + + finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg + finaliseAvailable (SemiConfiguredPackage pkg flags deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags deps') + where deps' = [ packageId pkg' + | dep <- deps + , let pkg' = case PackageIndex.lookupDependency selected dep of + [pkg''] -> pkg'' + _ -> impossible ] + +-- | Improve an existing installation plan by, where possible, swapping +-- packages we plan to install with ones that are already installed. +-- +improvePlan :: PackageIndex InstalledPackageInfo + -> PackageIndex PlanPackage + -> PackageIndex PlanPackage +improvePlan installed selected = foldl' improve selected + $ reverseTopologicalOrder selected + where + improve selected' = maybe selected' (flip PackageIndex.insert selected') + . improvePkg selected' + + -- The idea is to improve the plan by swapping a configured package for + -- an equivalent installed one. For a particular package the condition is + -- that the package be in a configured state, that a the same version be + -- already installed with the exact same dependencies and all the packages + -- in the plan that it depends on are in the installed state + improvePkg selected' pkgid = do + Configured pkg <- PackageIndex.lookupPackageId selected' pkgid + ipkg <- PackageIndex.lookupPackageId installed pkgid + guard $ sort (depends pkg) == nub (sort (depends ipkg)) + guard $ all (isInstalled selected') (depends pkg) + return (PreExisting ipkg) + + isInstalled selected' pkgid = + case PackageIndex.lookupPackageId selected' pkgid of + Just (PreExisting _) -> True + _ -> False + + reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg + -> [PackageIdentifier] + reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = PackageIndex.dependencyGraph index + +-- ------------------------------------------------------------ +-- * Adding and recording constraints +-- ------------------------------------------------------------ + +addPackageSelectConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints ExclusionReason +addPackageSelectConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) + reason = SelectedOther pkgid + +addPackageExcludeConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints ExclusionReason +addPackageExcludeConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint + (notThisPackageVersion pkgid) + reason = ExcludedByConfigureFail + +addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints + -> Satisfiable Constraints ExclusionReason +addPackageDependencyConstraint pkgid dep constraints = + Constraints.constrain dep reason constraints + where + reason = ExcludedByPackageDependency pkgid dep + +addTopLevelDependencyConstraint :: Dependency -> Constraints + -> Satisfiable Constraints ExclusionReason +addTopLevelDependencyConstraint dep constraints = + Constraints.constrain taggedDep reason constraints + where + taggedDep = TaggedDependency NoInstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +-- ------------------------------------------------------------ +-- * Reasons for constraints +-- ------------------------------------------------------------ + +-- | For every constraint we record we also record the reason that constraint +-- is needed. So if we end up failing due to conflicting constraints then we +-- can give an explnanation as to what was conflicting and why. +-- +data ExclusionReason = + + -- | We selected this other version of the package. That means we exclude + -- all the other versions. + SelectedOther PackageIdentifier + + -- | We excluded this version of the package because it failed to + -- configure probably because of unsatisfiable deps. + | ExcludedByConfigureFail + + -- | We excluded this version of the package because another package that + -- we selected imposed a dependency which this package did not satisfy. + | ExcludedByPackageDependency PackageIdentifier TaggedDependency + + -- | We excluded this version of the package because it did not satisfy + -- a dependency given as an original top level input. + -- + | ExcludedByTopLevelDependency Dependency + +-- | Given an excluded package and the reason it was excluded, produce a human +-- readable explanation. +-- +showExclusionReason :: PackageIdentifier -> ExclusionReason -> String +showExclusionReason pkgid (SelectedOther pkgid') = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " was selected instead" +showExclusionReason pkgid ExcludedByConfigureFail = + display pkgid ++ " was excluded because it could not be configured" +showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " requires " ++ display (untagDependency dep) +showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = + display pkgid ++ " was excluded because of the top level dependency " ++ + display dep + + +-- ------------------------------------------------------------ +-- * Logging progress and failures +-- ------------------------------------------------------------ + +data Log = Select SelectablePackage [SelectablePackage] +data Failure + = ConfigureFailed + SelectablePackage + [(Dependency, [(PackageIdentifier, [ExclusionReason])])] + | DependencyConflict + SelectedPackage TaggedDependency + [(PackageIdentifier, [ExclusionReason])] + | TopLevelDependencyConflict + Dependency + [(PackageIdentifier, [ExclusionReason])] + | TopLevelDependencyUnsatisfiable + Dependency + +showLog :: Log -> String +showLog (Select selected discarded) = + "selecting " ++ displayPkg selected ++ " " ++ kind selected + ++ case discarded of + [] -> "" + [d] -> " and discarding version " ++ display (packageVersion d) + _ -> " and discarding versions " + ++ listOf (display . packageVersion) discarded + where + kind (InstalledOnly _) = "(installed)" + kind (AvailableOnly _) = "(hackage)" + kind (InstalledAndAvailable _ _) = "(installed or hackage)" + +showFailure :: Failure -> String +showFailure (ConfigureFailed pkg missingDeps) = + "cannot configure " ++ displayPkg pkg ++ ". It requires " + ++ listOf (display . fst) missingDeps + ++ '\n' : unlines (map (uncurry whyNot) missingDeps) + + where + whyNot (Dependency name ver) [] = + "There is no available version of " ++ name + ++ " that satisfies " ++ display ver + + whyNot dep conflicts = + "For the dependency on " ++ display dep + ++ " there are these packages: " ++ listOf display pkgs + ++ ". However none of them are available.\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + + where pkgs = map fst conflicts + +showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = + "dependencies conflict: " + ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelDependencyConflict dep conflicts) = + "dependencies conflict: " + ++ "top level dependency " ++ display dep ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) = + "There is no available version of " ++ name + ++ " that satisfies " ++ display ver + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +impossible :: a +impossible = internalError "impossible" + +internalError :: String -> a +internalError msg = error $ "internal error: " ++ msg + +displayPkg :: Package pkg => pkg -> String +displayPkg = display . packageId + +listOf :: (a -> String) -> [a] -> String +listOf _ [] = [] +listOf disp [x0] = disp x0 +listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs + where go x [] = " and " ++ disp x + go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Constraints +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A set of satisfiable dependencies (package version constraints). +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Constraints ( + Constraints, + empty, + choices, + + constrain, + Satisfiable(..), + conflicting, + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageIdentifier, Package(packageId), packageVersion, packageName + , Dependency(Dependency) ) +import Distribution.Version + ( withinRange ) +import Distribution.Simple.Utils + ( comparing ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) + +import Data.List + ( foldl', sortBy ) +import Data.Monoid + ( Monoid(mempty) ) +import Control.Exception + ( assert ) + +-- | A set of constraints on package versions. For each package name we record +-- what other packages depends on it and what constraints they impose on the +-- version of the package. +-- +data (Package installed, Package available) + => Constraints installed available reason + = Constraints + + -- Remaining available choices + (PackageIndex (InstalledOrAvailable installed available)) + + -- Choices that we have excluded for some reason + -- usually by applying constraints + (PackageIndex (ExcludedPackage PackageIdentifier reason)) + +data ExcludedPackage pkg reason + = ExcludedPackage pkg [reason] -- reasons for excluding just the available + [reason] -- reasons for excluding installed and avail + +instance Package pkg => Package (ExcludedPackage pkg reason) where + packageId (ExcludedPackage p _ _) = packageId p + +-- | The intersection between the two indexes is empty +invariant :: (Package installed, Package available) + => Constraints installed available a -> Bool +invariant (Constraints available excluded) = + all (uncurry ok) [ (a, e) | InBoth a e <- merged ] + where + merged = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages excluded) + ok (InstalledOnly _) (ExcludedPackage _ _ []) = True + ok _ _ = False + +-- | An update to the constraints can move packages between the two piles +-- but not gain or loose packages. +transitionsTo :: (Package installed, Package available) + => Constraints installed available a + -> Constraints installed available a -> Bool +transitionsTo constraints @(Constraints available excluded ) + constraints'@(Constraints available' excluded') = + invariant constraints && invariant constraints' + && null availableGained && null excludedLost + && map packageId availableLost == map packageId excludedGained + + where + availableLost = foldr lost [] availableChange where + lost (OnlyInLeft pkg) rest = pkg : rest + lost (InBoth (InstalledAndAvailable _ pkg) + (InstalledOnly _)) rest = AvailableOnly pkg : rest + lost _ rest = rest + availableGained = [ pkg | OnlyInRight pkg <- availableChange ] + excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] + excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] + availableChange = mergeBy (\a b -> packageId a `compare` packageId b) + (allPackagesInOrder available) + (allPackagesInOrder available') + excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) + (allPackagesInOrder excluded) + (allPackagesInOrder excluded') + +--FIXME: PackageIndex.allPackages returns in sorted order case-insensitively +-- but that's no good for our merge which uses Ord +allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg] +allPackagesInOrder index = + concatMap snd + . sortBy (comparing fst) + $ [ (packageName pkg, grp) + | grp@(pkg:_) <- PackageIndex.allPackagesByName index ] + +-- | We construct 'Constraints' with an initial 'PackageIndex' of all the +-- packages available. +-- +empty :: (Package installed, Package available) + => PackageIndex installed + -> PackageIndex available + -> Constraints installed available reason +empty installed available = Constraints pkgs mempty + where + pkgs = PackageIndex.fromList + . map toInstalledOrAvailable + $ mergeBy (\a b -> packageId a `compare` packageId b) + (allPackagesInOrder installed) + (allPackagesInOrder available) + toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i + toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a + toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + +-- | The package choices that are still available. +-- +choices :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIndex (InstalledOrAvailable installed available) +choices (Constraints available _) = available + +data Satisfiable a reason + = Satisfiable a + | Unsatisfiable + | ConflictsWith [(PackageIdentifier, [reason])] + +constrain :: (Package installed, Package available) + => TaggedDependency + -> reason + -> Constraints installed available reason + -> Satisfiable (Constraints installed available reason) reason +constrain (TaggedDependency installedConstraint (Dependency name versionRange)) + reason constraints@(Constraints available excluded) + + | not anyRemaining + = if null conflicts then Unsatisfiable + else ConflictsWith conflicts + + | otherwise + = let constraints' = Constraints available' excluded' + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' + + where + -- This tells us if any packages would remain at all for this package name if + -- we applied this constraint. This amounts to checking if any package + -- satisfies the given constraint, including version range and installation + -- status. + -- + anyRemaining = any satisfiesConstraint availableChoices + + conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll) + | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices + , satisfiesVersionConstraint pkg ] + + -- Applying this constraint may involve deleting some choices for this + -- package name, or restricting which install states are available. + available' = updateAvailable available + updateAvailable = flip (foldl' (flip update)) availableChoices where + update pkg | not (satisfiesVersionConstraint pkg) + = PackageIndex.deletePackageId (packageId pkg) + update _ | installedConstraint == NoInstalledConstraint + = id + update pkg = case pkg of + InstalledOnly _ -> id + AvailableOnly _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg) + InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i) + + -- Applying the constraint means adding exclusions for the packages that + -- we're just freshly excluding, ie the ones we're removing from available. + excluded' = addNewExcluded . addOldExcluded $ excluded + addNewExcluded index = foldl' (flip exclude) index availableChoices where + exclude pkg + | not (satisfiesVersionConstraint pkg) + = PackageIndex.insert $ ExcludedPackage pkgid [] [reason] + | installedConstraint == NoInstalledConstraint + = id + | otherwise = case pkg of + InstalledOnly _ -> id + AvailableOnly _ -> PackageIndex.insert + (ExcludedPackage pkgid [reason] []) + InstalledAndAvailable _ _ -> + case PackageIndex.lookupPackageId excluded pkgid of + Just (ExcludedPackage _ avail both) -> + PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) + Nothing -> + PackageIndex.insert (ExcludedPackage pkgid [reason] []) + where pkgid = packageId pkg + + -- Additionally we have to add extra exclusions for any already-excluded + -- packages that happen to be covered by the (inverse of the) constraint. + addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where + exclude (ExcludedPackage pkgid avail both) + -- if it doesn't satisfy the version constraint then we exclude the + -- package as a whole, the available or the installed instances or both. + | not (satisfiesVersionConstraint pkgid) + = PackageIndex.insert (ExcludedPackage pkgid avail (reason:both)) + -- if on the other hand it does satisfy the constraint and we were also + -- constraining to just the installed version then we exclude just the + -- available instance. + | installedConstraint == InstalledConstraint + = PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) + | otherwise = id + + -- util definitions + availableChoices = PackageIndex.lookupPackageName available name + excludedChoices = PackageIndex.lookupPackageName excluded name + + satisfiesConstraint pkg = satisfiesVersionConstraint pkg + && satisfiesInstallStateConstraint pkg + + satisfiesVersionConstraint pkg = + packageVersion pkg `withinRange` versionRange + + satisfiesInstallStateConstraint = case installedConstraint of + NoInstalledConstraint -> \_ -> True + InstalledConstraint -> \pkg -> case pkg of + AvailableOnly _ -> False + _ -> True + +conflicting :: (Package installed, Package available) + => Constraints installed available reason + -> Dependency + -> [(PackageIdentifier, [reason])] +conflicting (Constraints _ excluded) dep = + [ (pkgid, reasonsAvail ++ reasonsAll) --TODO + | ExcludedPackage pkgid reasonsAvail reasonsAll <- + PackageIndex.lookupDependency excluded dep ] diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/TopDown/Types.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Types for the top-down dependency resolver. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Types where + +import Distribution.Client.Types + ( AvailablePackage(..) ) + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Package + ( PackageIdentifier, Dependency, Package(packageId) ) +import Distribution.PackageDescription + ( FlagAssignment ) + +-- ------------------------------------------------------------ +-- * The various kinds of packages +-- ------------------------------------------------------------ + +type SelectablePackage + = InstalledOrAvailable InstalledPackage UnconfiguredPackage + +type SelectedPackage + = InstalledOrAvailable InstalledPackage SemiConfiguredPackage + +data InstalledOrAvailable installed available + = InstalledOnly installed + | AvailableOnly available + | InstalledAndAvailable installed available + +type TopologicalSortNumber = Int + +data InstalledPackage + = InstalledPackage + InstalledPackageInfo + !TopologicalSortNumber + [PackageIdentifier] + +data UnconfiguredPackage + = UnconfiguredPackage + AvailablePackage + !TopologicalSortNumber + FlagAssignment + +data SemiConfiguredPackage + = SemiConfiguredPackage + AvailablePackage -- package info + FlagAssignment -- total flag assignment for the package + [Dependency] -- dependencies we end up with when we apply + -- the flag assignment + +instance Package InstalledPackage where + packageId (InstalledPackage p _ _) = packageId p + +instance Package UnconfiguredPackage where + packageId (UnconfiguredPackage p _ _) = packageId p + +instance Package SemiConfiguredPackage where + packageId (SemiConfiguredPackage p _ _) = packageId p + +instance (Package installed, Package available) + => Package (InstalledOrAvailable installed available) where + packageId (InstalledOnly p ) = packageId p + packageId (AvailableOnly p ) = packageId p + packageId (InstalledAndAvailable p _) = packageId p + +-- ------------------------------------------------------------ +-- * Tagged Dependency type +-- ------------------------------------------------------------ + +-- | Installed packages can only depend on other installed packages while +-- packages that are not yet installed but which we plan to install can depend +-- on installed or other not-yet-installed packages. +-- +-- This makes life more complex as we have to remember these constraints. +-- +data TaggedDependency = TaggedDependency InstalledConstraint Dependency +data InstalledConstraint = InstalledConstraint | NoInstalledConstraint + deriving Eq + +untagDependency :: TaggedDependency -> Dependency +untagDependency (TaggedDependency _ dep) = dep diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Types ( + PackageName, + DependencyResolver, + PackageVersionPreference(..), + Progress(..), + foldProgress, + ) where + +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( OS, Arch ) + +import Prelude hiding (fail) + +type PackageName = String + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver = OS + -> Arch + -> CompilerId + -> PackageIndex InstalledPackageInfo + -> PackageIndex AvailablePackage + -> (PackageName -> PackageVersionPreference) + -> [UnresolvedDependency] + -> Progress String String [InstallPlan.PlanPackage] + +-- | A per-package preference on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackageVersionPreference = PreferInstalled | PreferLatest + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- retult which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with +-- two base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Functor (Progress step fail) where + fmap f = foldProgress Step Fail (Done . f) + +instance Monad (Progress step fail) where + return a = Done a + p >>= f = foldProgress Step Fail f p diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Fetch.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + + -- * Commands + fetch, + + -- * Utilities + fetchPackage, + isFetched, + downloadIndex, + ) where + +import Distribution.Client.Types + ( UnresolvedDependency (..), AvailablePackage(..) + , AvailablePackageSource(..) + , Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress, PackagesVersionPreference(..) ) +import Distribution.Client.Dependency.Types + ( foldProgress ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI) + +import Distribution.Package + ( PackageIdentifier(..), Dependency(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( Compiler(compilerId), PackageDB ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.Configure + ( getInstalledPackages ) +import Distribution.Simple.Utils + ( die, notice, info, debug, setupMessage + , copyFileVerbose, writeFileAtomic ) +import Distribution.System + ( buildOS, buildArch ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Control.Monad + ( when, filterM ) +import System.Directory + ( doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath, uriScheme) ) +import Network.HTTP + ( ConnError(..), Response(..) ) + + +downloadURI :: Verbosity + -> FilePath -- ^ Where to put it + -> URI -- ^ What to download + -> IO (Maybe ConnError) +downloadURI verbosity path uri | uriScheme uri == "file:" = do + copyFileVerbose verbosity (uriPath uri) path + return Nothing +downloadURI verbosity path uri = do + eitherResult <- getHTTP verbosity uri + case eitherResult of + Left err -> return (Just err) + Right rsp + | rspCode rsp == (2,0,0) + -> writeFileAtomic path (rspBody rsp) + --FIXME: check the content-length header matches the body length. + --TODO: stream the download into the file rather than buffering the whole + -- thing in memory. + -- remember the ETag so we can not re-download if nothing changed. + >> return Nothing + + | otherwise + -> return (Just (ErrorMisc ("Unsucessful HTTP code: " ++ show (rspCode rsp)))) + +-- Downloads a package to [config-dir/packages/package-id] and returns the path to the package. +downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String +downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid = + return (packageFile repo pkgid) + +downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do + let uri = packageURI remoteRepo pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + debug verbosity $ "GET " ++ show uri + createDirectoryIfMissing True dir + status <- downloadURI verbosity path uri + case status of + Just err -> die $ "Failed to download '" ++ display pkgid + ++ "': " ++ show err + Nothing -> return path + +-- Downloads an index file to [config-dir/packages/serv-id]. +downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath +downloadIndex verbosity repo cacheDir = do + let uri = (remoteRepoURI repo) { + uriPath = uriPath (remoteRepoURI repo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + mbError <- downloadURI verbosity path uri + case mbError of + Just err -> die $ "Failed to download index '" ++ show err ++ "'" + Nothing -> return path + +-- |Returns @True@ if the package has already been fetched. +isFetched :: AvailablePackage -> IO Bool +isFetched (AvailablePackage pkgid _ source) = case source of + LocalUnpackedPackage -> return True + RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid) + +-- |Fetch a package if we don't have it already. +fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String +fetchPackage verbosity repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do notice verbosity $ "'" ++ display pkgid ++ "' is cached." + return (packageFile repo pkgid) + else do setupMessage verbosity "Downloading" pkgid + downloadPackage verbosity repo pkgid + +-- |Fetch a list of packages and their dependencies. +fetch :: Verbosity + -> PackageDB + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> [UnresolvedDependency] + -> IO () +fetch verbosity packageDB repos comp conf deps = do + installed <- getInstalledPackages verbosity comp packageDB conf + available <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available deps + + let -- Hide the packages given on the command line so that the dep resolver + -- will decide that they need fetching, even if they're already + -- installed. Sicne we want to get the source packages of things we might + -- have installed (but not have the sources for). + installed' = fmap (hideGivenDeps deps') installed + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + + let progress = resolveDependenciesWithProgress + buildOS buildArch (compilerId comp) + installed' available PreferLatestForSelected deps' + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> die message + Right pkgs -> do + ps <- filterM (fmap not . isFetched) + [ pkg | (InstallPlan.Configured + (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList pkgs ] + when (null ps) $ + notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already cached." + + sequence_ + [ fetchPackage verbosity repo pkgid + | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ] + +-- |Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +packageFile :: Repo -> PackageIdentifier -> FilePath +packageFile repo pkgid = packageDir repo pkgid + display pkgid + <.> "tar.gz" + +-- |Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +packageDir :: Repo -> PackageIdentifier -> FilePath +packageDir repo pkgid = repoLocalDir repo + pkgName pkgid + display (pkgVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +packageURI :: RemoteRepo -> PackageIdentifier -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,pkgName pkgid + ,display (pkgVersion pkgid) + ,display pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"packages" + ,display pkgid + ,"tarball"] + } diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/HttpUtils.hs @@ -0,0 +1,145 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils (getHTTP, proxy, isOldHackageURI) where + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) +import Network.Stream (Result) +import Network.Browser + ( Proxy (..), Authority (..), browse + , setOutHandler, setErrHandler, setProxy, request) +import Control.Monad + ( mplus, join ) +#ifdef WIN32 +import System.Win32.Types + ( DWORD, HKEY ) +import System.Win32.Registry + ( hKEY_CURRENT_USER, regOpenKey, regCloseKey + , regQueryValue, regQueryValueEx ) +import Control.Exception + ( handle, bracket ) +import Foreign + ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#else +import System.Environment (getEnvironment) +#endif + +import qualified Paths_cabal_install (version) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (warn, debug) +import Distribution.Text + ( display ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories ) + +-- FIXME: all this proxy stuff is far too complicated, especially parsing +-- the proxy strings. Network.Browser should have a way to pick up the +-- proxy settings hiding all this system-dependent stuff below. + +-- try to read the system proxy settings on windows or unix +proxyString :: IO (Maybe String) +#ifdef WIN32 +-- read proxy settings from the windows registry +proxyString = handle (\_ -> return Nothing) $ + bracket (regOpenKey hive path) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing + where + -- some sources say proxy settings should be at + -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows + -- \CurrentVersion\Internet Settings\ProxyServer + -- but if the user sets them with IE connection panel they seem to + -- end up in the following place: + hive = hKEY_CURRENT_USER + path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" + + regQueryValueDWORD :: HKEY -> String -> IO DWORD + regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr +#else +-- read proxy settings by looking for an env var +proxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) +#endif + +-- |Get the local proxy settings +proxy :: Verbosity -> IO Proxy +proxy verbosity = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseHttpProxy str of + Nothing -> do + warn verbosity $ "invalid http proxy uri: " ++ show str + warn verbosity $ "proxy uri must be http with a hostname" + warn verbosity $ "ignoring http proxy, trying a direct connection" + return NoProxy + Just p -> return p + +-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ +-- which lack the @\"http://\"@ URI scheme. The problem is that +-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme +-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. +-- +-- So our strategy is to try parsing as normal uri first and if it lacks the +-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. +-- +parseHttpProxy :: String -> Maybe Proxy +parseHttpProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = case parseAbsoluteURI str' of + Just uri@URI { uriAuthority = Just _ } + -> Just uri + _ -> Nothing + +uri2proxy :: URI -> Maybe Proxy +uri2proxy uri@URI{ uriScheme = "http:" + , uriAuthority = Just (URIAuth auth' host port) + } = Just (Proxy (host ++ port) auth) + where auth = if null auth' + then Nothing + else Just (AuthBasic "" usr pwd uri) + (usr,pwd') = break (==':') auth' + pwd = case pwd' of + ':':cs -> cs + _ -> pwd' +uri2proxy _ = Nothing + +mkRequest :: URI -> Request +mkRequest uri = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = "" } + where userAgent = "cabal-install/" ++ display Paths_cabal_install.version + +-- |Carry out a GET request, using the local proxy settings +getHTTP :: Verbosity -> URI -> IO (Result Response) +getHTTP verbosity uri = do + p <- proxy verbosity + let req = mkRequest uri + (_, resp) <- browse $ do + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setProxy p + request req + return (Right resp) + +-- Utility function for legacy support. +isOldHackageURI :: URI -> Bool +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] + _ -> False diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/IndexUtils.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getAvailablePackages, + readRepoIndex, + disambiguatePackageName, + disambiguateDependencies + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) + +import Distribution.Package + ( PackageIdentifier(..), Package(..), Dependency(Dependency) ) +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.PackageDescription + ( parsePackageDescription ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Text + ( simpleParse ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) + +import Data.Maybe (catMaybes) +import Data.Monoid (Monoid(..)) +import Control.Exception (evaluate) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.IO.Error (isDoesNotExistError) + + +getAvailablePackages :: Verbosity -> [Repo] + -> IO (PackageIndex AvailablePackage) +getAvailablePackages verbosity repos = do + info verbosity "Reading available packages..." + pkgss <- mapM (readRepoIndex verbosity) repos + evaluate (mconcat pkgss) + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage) +readRepoIndex verbosity repo = + handleNotFound $ do + let indexFile = repoLocalDir repo "00-index.tar" + pkgs <- either fail return . parseRepoIndex =<< BS.readFile indexFile + evaluate (PackageIndex.fromList pkgs) + + where + -- | Parse a repository index file from a 'ByteString'. + -- + -- All the 'AvailablePackage's are marked as having come from the given 'Repo'. + -- + parseRepoIndex :: ByteString -> Either String [AvailablePackage] + parseRepoIndex = either Left (Right . catMaybes . map extractPkg) + . check [] . Tar.read + + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es + + extractPkg :: Tar.Entry -> Maybe AvailablePackage + extractPkg entry + | takeExtension fileName == ".cabal" + = case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParse vers of + Just ver -> Just AvailablePackage { + packageInfoId = PackageIdentifier pkgname ver, + packageDescription = descr, + packageSource = RepoTarballPackage repo + } + _ -> Nothing + where + parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack + . Tar.fileContent $ entry + descr = case parsed of + ParseOk _ d -> d + _ -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + | otherwise = Nothing + where + fileName = Tar.fileName entry + + handleNotFound action = catch action $ \e -> if isDoesNotExistError e + then do + case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' does not exist. Run 'cabal update' to download it." + Right _localRepo -> warn verbosity $ + "The package list for the local repo '" ++ repoLocalDir repo + ++ "' is missing. The repo is invalid." + return mempty + else ioError e + +-- | Disambiguate a set of packages using 'disambiguatePackage' and report any +-- ambiguities to the user. +-- +disambiguateDependencies :: PackageIndex AvailablePackage + -> [UnresolvedDependency] + -> IO [UnresolvedDependency] +disambiguateDependencies index deps = do + let names = [ (name, disambiguatePackageName index name) + | UnresolvedDependency (Dependency name _) _ <- deps ] + in case [ (name, matches) | (name, Right matches) <- names ] of + [] -> return + [ UnresolvedDependency (Dependency name vrange) flags + | (UnresolvedDependency (Dependency _ vrange) flags, + (_, Left name)) <- zip deps names ] + ambigious -> die $ unlines + [ if null matches + then "There is no package named " ++ name + else "The package name " ++ name ++ "is ambigious. " + ++ "It could be: " ++ intercalate ", " matches + | (name, matches) <- ambigious ] + +-- | Given an index of known packages and a package name, figure out which one it +-- might be referring to. If there is an exact case-sensitive match then that's +-- ok. If it matches just one package case-insensitively then that's also ok. +-- The only problem is if it matches multiple packages case-insensitively, in +-- that case it is ambigious. +-- +disambiguatePackageName :: PackageIndex AvailablePackage + -> String + -> Either String [String] +disambiguatePackageName index name = + case PackageIndex.searchByName index name of + PackageIndex.None -> Right [] + PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs))) + PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg) + | (pkg:_) <- pkgss ] diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Install.hs @@ -0,0 +1,554 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + install, + upgrade, + ) where + +import Data.List + ( unfoldr ) +import Data.Maybe + ( isJust ) +import Control.Exception as Exception + ( handle, Exception ) +import Control.Monad + ( when, unless, forM_ ) +import System.Directory + ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>), takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode) ) + +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress, PackagesVersionPreference(..) + , upgradableDependencies ) +import Distribution.Client.Dependency.Types (Progress(..), foldProgress) +import Distribution.Client.Fetch (fetchPackage) +-- import qualified Distribution.Client.Info as Info +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup + ( InstallFlags(..), configureCommand, filterConfigureFlags ) +import Distribution.Client.Config + ( defaultLogsDir, defaultCabalDir ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Available + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), ConfiguredPackage(..) + , BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..), RemoteRepo(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import Paths_cabal_install (getBinDir) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), PackageDB(..) ) +import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import Distribution.Simple.Configure (getInstalledPackages) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Simple.Setup as Cabal +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Setup + ( flagToMaybe ) +import Distribution.Simple.Utils + ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, toPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.Package + ( PackageIdentifier(..), Package(..), thisPackageVersion + , Dependency(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription, readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Version + ( Version, VersionRange(AnyVersion, ThisVersion) ) +import Distribution.Simple.Utils as Utils + ( notice, info, warn, die, intercalate ) +import Distribution.System + ( OS(Windows), buildOS, Arch, buildArch ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, showForCabal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +data InstallMisc = InstallMisc { + rootCmd :: Maybe FilePath, + libVersion :: Maybe Version + } + +-- |Installs the packages needed to satisfy a list of dependencies. +install, upgrade + :: Verbosity + -> PackageDB + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> Cabal.ConfigFlags + -> InstallFlags + -> [UnresolvedDependency] + -> IO () +install verbosity packageDB repos comp conf configFlags installFlags deps = + installWithPlanner planner + verbosity packageDB repos comp conf configFlags installFlags + where + planner :: Planner + planner | null deps = planLocalPackage verbosity comp configFlags + | otherwise = planRepoPackages PreferLatestForSelected + comp installFlags deps + +upgrade verbosity packageDB repos comp conf configFlags installFlags deps = + installWithPlanner planner + verbosity packageDB repos comp conf configFlags installFlags + where + planner :: Planner + planner | null deps = planUpgradePackages comp + | otherwise = planRepoPackages PreferAllLatest + comp installFlags deps + +type Planner = Maybe (PackageIndex InstalledPackageInfo) + -> PackageIndex AvailablePackage + -> IO (Progress String String InstallPlan) + +-- |Installs the packages generated by a planner. +installWithPlanner :: + Planner + -> Verbosity + -> PackageDB + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> Cabal.ConfigFlags + -> InstallFlags + -> IO () +installWithPlanner planner verbosity packageDB repos comp conf configFlags installFlags = do + installed <- getInstalledPackages verbosity comp packageDB conf + available <- getAvailablePackages verbosity repos + + progress <- planner installed available + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> die message + Right installPlan -> do + let nothingToInstall = null (InstallPlan.ready installPlan) + when nothingToInstall $ + notice verbosity $ + "No packages to be installed. All the requested packages are " + ++ "already installed.\n If you want to reinstall anyway then use " + ++ "the --reinstall flag." + + when (dryRun || verbosity >= verbose) $ + printDryRun verbosity installPlan + + unless dryRun $ do + logsDir <- defaultLogsDir + let os = InstallPlan.planOS installPlan + arch = InstallPlan.planArch installPlan + compid = InstallPlan.planCompiler installPlan + installPlan' <- + executeInstallPlan installPlan $ \cpkg -> + installConfiguredPackage os arch compid configFlags + cpkg $ \configFlags' src pkg -> + installAvailablePackage verbosity (packageId pkg) src $ \mpath -> + installUnpackedPackage verbosity (setupScriptOptions installed) + miscOptions configFlags' installFlags + compid pkg mpath (useLogFile logsDir) + + let buildReports = BuildReports.fromInstallPlan installPlan' + BuildReports.storeAnonymous buildReports + BuildReports.storeLocal buildReports + when useDetailedBuildReports $ + storeDetailedBuildReports logsDir buildReports + symlinkBinaries verbosity configFlags installFlags installPlan' + printBuildFailures installPlan' + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe AnyVersion ThisVersion (libVersion miscOptions), + useCompiler = Just comp, + usePackageIndex = if packageDB == UserPackageDB then index else Nothing, + useProgramConfig = conf, + useDistPref = Cabal.fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (Cabal.configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + useDetailedBuildReports = Cabal.fromFlagOrDefault False (installBuildReports installFlags) + useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath) + useLogFile logsDir = fmap substLogFileName logFileTemplate + where + logFileTemplate + | useDetailedBuildReports = Just $ logsDir "$pkgid" <.> "log" + | otherwise = Cabal.flagToMaybe (installLogFile installFlags) + substLogFileName path pkg = fromPathTemplate + . substPathTemplate env + . toPathTemplate + $ path + where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + dryRun = Cabal.fromFlagOrDefault False (installDryRun installFlags) + miscOptions = InstallMisc { + rootCmd = if Cabal.fromFlag (Cabal.configUserInstall configFlags) + then Nothing -- ignore --root-cmd if --user. + else Cabal.flagToMaybe (installRootCmd installFlags), + libVersion = Cabal.flagToMaybe (installCabalVersion installFlags) + } + +storeDetailedBuildReports :: FilePath -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports logsDir reports + = forM_ reports $ \(report,repo) -> + do buildLog <- readFile (logsDir display (BuildReports.package report) <.> "log") + case repoKind repo of + Left remoteRepo + -> do dotCabal <- defaultCabalDir + let destDir = dotCabal "reports" remoteRepoName remoteRepo + dest = destDir display (BuildReports.package report) <.> "log" + createDirectoryIfMissing True destDir -- FIXME + writeFile dest (show (BuildReports.show report, buildLog)) + Right{} -> return () + + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner +planLocalPackage verbosity comp configFlags installed available = do + pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + let -- The trick is, we add the local package to the available index and + -- remove it from the installed index. Then we ask to resolve a + -- dependency on exactly that package. So the resolver ends up having + -- to pick the local package. + available' = PackageIndex.insert localPkg available + installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage + } + localPkgDep = UnresolvedDependency { + dependency = thisPackageVersion (packageId localPkg), + depFlags = Cabal.configConfigurationsFlags configFlags + } + + return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) + installed' available' PreferLatestForSelected [localPkgDep] + +-- | Make an 'InstallPlan' for the given dependencies. +-- +planRepoPackages :: PackagesVersionPreference -> Compiler -> InstallFlags + -> [UnresolvedDependency] -> Planner +planRepoPackages pref comp installFlags deps installed available = do + deps' <- IndexUtils.disambiguateDependencies available deps + let installed' + | Cabal.fromFlagOrDefault False (installReinstall installFlags) + = fmap (hideGivenDeps deps') installed + | otherwise = installed + return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) + installed' available pref deps' + where + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + +planUpgradePackages :: Compiler -> Planner +planUpgradePackages comp (Just installed) available = return $ + resolveDependenciesWithProgress buildOS buildArch (compilerId comp) + (Just installed) available PreferAllLatest + [ UnresolvedDependency dep [] + | dep <- upgradableDependencies installed available ] +planUpgradePackages comp _ _ = + die $ display (compilerId comp) + ++ " does not track installed packages so cabal cannot figure out what" + ++ " packages need to be upgraded." + +printDryRun :: Verbosity -> InstallPlan -> IO () +printDryRun verbosity plan = case unfoldr next plan of + [] -> return () + pkgs -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map display pkgs + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid result plan') + where pkgid = packageId pkg + result = BuildOk DocsNotTried TestsNotTried + --FIXME: This is a bit of a hack, + -- pretending that each package is installed + +symlinkBinaries :: Verbosity + -> Cabal.ConfigFlags + -> InstallFlags + -> InstallPlan -> IO () +symlinkBinaries verbosity configFlags installFlags plan = do + failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = Cabal.fromFlag (installSymlinkBinDir installFlags) + +printBuildFailures :: InstallPlan -> IO () +printBuildFailures plan = + case [ (pkg, reason) + | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of + [] -> return () + failed -> die . unlines + $ "Error: some packages failed to install:" + : [ display (packageId pkg) ++ printFailureReason reason + | (pkg, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ display pkgid + ++ " which failed to install." + UnpackFailed e -> " failed while unpacking the package." + ++ " The exception was:\n " ++ show e + ConfigureFailed e -> " failed during the configure step." + ++ " The exception was:\n " ++ show e + BuildFailed e -> " failed during the building phase." + ++ " The exception was:\n " ++ show e + InstallFailed e -> " failed during the final install step." + ++ " The exception was:\n " ++ show e + +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 + where + updatePlan pkgid (Right buildSuccess) = + InstallPlan.completed pkgid buildSuccess + + updatePlan pkgid (Left buildFailure) = + InstallPlan.failed pkgid buildFailure depsFailure + where + depsFailure = DependentFailed pkgid + -- So this first pkgid failed for whatever reason (buildFailure). + -- All the other packages that depended on this pkgid, which we + -- now cannot build, we mark as failing due to 'DependentFailed' + -- which kind of means it was not their fault. + +-- | Call an installer for an 'AvailablePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +installConfiguredPackage :: OS -> Arch -> CompilerId + -> Cabal.ConfigFlags -> ConfiguredPackage + -> (Cabal.ConfigFlags -> AvailablePackageSource + -> PackageDescription -> a) + -> a +installConfiguredPackage os arch comp configFlags + (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) + installPkg = installPkg configFlags { + Cabal.configConfigurationsFlags = flags, + Cabal.configConstraints = map thisPackageVersion deps + } source pkg + where + pkg = case finalizePackageDescription flags + (Nothing :: Maybe (PackageIndex PackageDescription)) + os arch comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + +installAvailablePackage + :: Verbosity -> PackageIdentifier -> AvailablePackageSource + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installAvailablePackage _ _ LocalUnpackedPackage installPkg = + installPkg Nothing + +installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = do + pkgPath <- fetchPackage verbosity repo pkgid + tmp <- getTemporaryDirectory + let tmpDirPath = tmp ("TMP" ++ display pkgid) + path = tmpDirPath display pkgid + onFailure UnpackFailed $ withTempDirectory verbosity tmpDirPath $ do + info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ tmpDirPath ++ "..." + extractTarGzFile tmpDirPath pkgPath + let descFilePath = tmpDirPath display pkgid + pkgName pkgid <.> "cabal" + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath + installPkg (Just path) + +installUnpackedPackage :: Verbosity + -> SetupScriptOptions + -> InstallMisc + -> Cabal.ConfigFlags + -> InstallFlags + -> 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 + configFlags installConfigFlags + compid pkg workingDir useLogFile = + + -- Configure phase + onFailure ConfigureFailed $ do + setup configureCommand configureFlags + + -- Build phase + onFailure BuildFailed $ do + setup buildCommand buildFlags + + -- Doc generation phase + docsResult <- if shouldHaddock + then Exception.handle (\_ -> return DocsFailed) $ do + setup Cabal.haddockCommand haddockFlags + return DocsOk + else return DocsNotTried + + -- Tests phase + testsResult <- return TestsNotTried --TODO: add optional tests + + -- Install phase + onFailure InstallFailed $ + withWin32SelfUpgrade verbosity configFlags compid pkg $ do + case rootCmd miscOptions of + (Just cmd) -> reexec cmd + Nothing -> setup Cabal.installCommand installFlags + return (Right (BuildOk docsResult testsResult)) + + where + configureFlags = filterConfigureFlags configFlags { + Cabal.configVerbosity = Cabal.toFlag verbosity' + } + buildCommand = Cabal.buildCommand defaultProgramConfiguration + buildFlags _ = Cabal.emptyBuildFlags { + Cabal.buildDistPref = Cabal.configDistPref configFlags, + Cabal.buildVerbosity = Cabal.toFlag verbosity' + } + shouldHaddock = Cabal.fromFlagOrDefault False + (installDocumentation installConfigFlags) + haddockFlags _ = Cabal.emptyHaddockFlags { + Cabal.haddockDistPref = Cabal.configDistPref configFlags, + Cabal.haddockVerbosity = Cabal.toFlag verbosity' + } + installFlags _ = Cabal.emptyInstallFlags { + Cabal.installDistPref = Cabal.configDistPref configFlags, + Cabal.installVerbosity = Cabal.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) + + 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: + bindir <- getBinDir + let self = bindir "cabal" <.> exeExtension + weExist <- doesFileExist self + if weExist + then inDir workingDir $ + rawSystemExit verbosity cmd + [self, "install", "--only" + ,"--verbose=" ++ showForCabal verbosity] + else die $ "Unable to find cabal executable at: " ++ self + +-- helper +onFailure :: (Exception -> BuildFailure) -> IO BuildResult -> IO BuildResult +onFailure result = Exception.handle (return . Left . result) + + +withWin32SelfUpgrade :: Verbosity + -> Cabal.ConfigFlags + -> CompilerId + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (Cabal.fromFlag (Cabal.configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compilerFlavor _) = compid + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = Cabal.fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (Cabal.configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (Cabal.configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs Cabal.fromFlagOrDefault + defaultDirs (Cabal.configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid compid InstallDirs.NoCopyDest templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compid diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/InstallPlan.hs @@ -0,0 +1,498 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + ConfiguredPackage(..), + PlanPackage(..), + + -- * Operations on 'InstallPlan's + new, + toList, + ready, + completed, + failed, + + -- ** Query functions + planOS, + planArch, + planCompiler, + + -- * Checking valididy of plans + valid, + closed, + consistent, + acyclic, + configuredPackageValid, + + -- ** Details on invalid plans + PlanProblem(..), + showPlanProblem, + PackageProblem(..), + showPackageProblem, + problems, + configuredPackageProblems + ) where + +import Distribution.Client.Types + ( AvailablePackage(packageDescription), ConfiguredPackage(..) + , BuildFailure, BuildSuccess ) +import Distribution.Package + ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) + , packageName, Dependency(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.PackageDescription + ( GenericPackageDescription(genPackageFlags) + , PackageDescription(buildDepends) + , Flag(flagName), FlagName(..) ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Text + ( display ) +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.Client.Utils + ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate ) + +import Data.List + ( sort, sortBy ) +import Data.Maybe + ( fromMaybe ) +import qualified Data.Graph as Graph +import Data.Graph (Graph) +import Control.Exception + ( assert ) + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of available +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Available package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available which means they could be re-installed if +-- required, though there will also be packages which are not available and +-- cannot be re-installed. Very often there will be extra versions available +-- than are installed. Sometimes we may like to prefer installed packages over +-- available ones or perhaps always prefer the latest available version whether +-- installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and available +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- 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 +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +data PlanPackage = PreExisting InstalledPackageInfo + | Configured ConfiguredPackage + | Installed ConfiguredPackage BuildSuccess + | Failed ConfiguredPackage BuildFailure + +instance Package PlanPackage where + packageId (PreExisting pkg) = packageId pkg + packageId (Configured 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 (Installed pkg _) = depends pkg + depends (Failed pkg _) = depends pkg + +data InstallPlan = InstallPlan { + planIndex :: PackageIndex PlanPackage, + planGraph :: Graph, + planGraphRev :: Graph, + planPkgIdOf :: Graph.Vertex -> PackageIdentifier, + planVertexOf :: PackageIdentifier -> Graph.Vertex, + planOS :: OS, + planArch :: Arch, + planCompiler :: CompilerId + } + +invariant :: InstallPlan -> Bool +invariant plan = + valid (planOS plan) (planArch plan) (planCompiler plan) (planIndex plan) + +internalError :: String -> a +internalError msg = error $ "InstallPlan: internal error: " ++ msg + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage + -> Either [PlanProblem] InstallPlan +new os arch compiler index = + case problems os arch compiler index of + [] -> Right InstallPlan { + planIndex = index, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgIdOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planOS = os, + planArch = arch, + planCompiler = compiler + } + where (graph, vertexToPkgId, pkgIdToVertex) = + PackageIndex.dependencyGraph index + noSuchPkgId = internalError "package is not in the graph" + probs -> Left probs + +toList :: InstallPlan -> [PlanPackage] +toList = PackageIndex.allPackages . planIndex + +-- | The packages that are ready to be installed. That is they are in the +-- configured state and have all their dependencies installed already. +-- The plan is complete if the result is @[]@. +-- +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) ] + readyPackages = filter (all isInstalled . depends) configuredPackages + isInstalled pkg = + case PackageIndex.lookupPackageId (planIndex plan) pkg of + Just (Configured _) -> False + Just (Failed _ _) -> internalError depOnFailed + Just (PreExisting _) -> True + Just (Installed _ _) -> True + Nothing -> internalError incomplete + incomplete = "install plan is not closed" + depOnFailed = "configured package depends on failed package" + +-- | 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 have had no uninstalled dependent packages. +-- +completed :: PackageIdentifier + -> BuildSuccess + -> InstallPlan -> InstallPlan +completed pkgid buildResult plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.insert installed (planIndex plan) + } + installed = Installed (lookupConfiguredPackage 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. +-- +failed :: PackageIdentifier -- ^ The id of the package that failed to install + -> BuildFailure -- ^ The build result to use for the failed package + -> BuildFailure -- ^ The build result to use for its dependencies + -> InstallPlan + -> InstallPlan +failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.merge (planIndex plan) failures + } + pkg = lookupConfiguredPackage plan pkgid + failures = PackageIndex.fromList + $ Failed pkg buildResult + : [ Failed pkg' buildResult' + | Just pkg' <- map (lookupConfiguredPackage' plan) + $ packagesThatDependOn plan pkgid ] + +-- | lookup the reachable packages in the reverse dependency graph +-- +packagesThatDependOn :: InstallPlan + -> PackageIdentifier -> [PackageIdentifier] +packagesThatDependOn plan = map (planPkgIdOf plan) + . tail + . Graph.reachable (planGraphRev plan) + . planVertexOf plan + +-- | lookup a package that we expect to be in the configured state +-- +lookupConfiguredPackage :: InstallPlan + -> PackageIdentifier -> ConfiguredPackage +lookupConfiguredPackage plan pkgid = + case PackageIndex.lookupPackageId (planIndex plan) pkgid of + Just (Configured pkg) -> pkg + _ -> internalError $ "not configured or no such pkg " ++ display pkgid + +-- | lookup a package that we expect to be in the configured or failed state +-- +lookupConfiguredPackage' :: InstallPlan + -> PackageIdentifier -> Maybe ConfiguredPackage +lookupConfiguredPackage' plan pkgid = + case PackageIndex.lookupPackageId (planIndex plan) pkgid of + Just (Configured pkg) -> Just pkg + Just (Failed _ _) -> Nothing + _ -> internalError $ "not configured or no such pkg " ++ display pkgid + +-- ------------------------------------------------------------ +-- * Checking valididy of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: OS -> Arch -> CompilerId -> PackageIndex PlanPackage -> Bool +valid os arch comp index = null (problems os arch comp index) + +data PlanProblem = + PackageInvalid ConfiguredPackage [PackageProblem] + | PackageMissingDeps PlanPackage [PackageIdentifier] + | PackageCycle [PlanPackage] + | PackageInconsistency String [(PackageIdentifier, Version)] + | PackageStateInvalid PlanPackage PlanPackage + +showPlanProblem :: PlanProblem -> String +showPlanProblem (PackageInvalid pkg packageProblems) = + "Package " ++ display (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] + +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (packageId pkg) + ++ " depends on the following packages which are missing from the plan " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ display (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + showPlanState (Installed _ _) = "installed" + showPlanState (Failed _ _) = "failed" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: OS -> Arch -> CompilerId + -> PackageIndex PlanPackage -> [PlanProblem] +problems os arch comp index = + [ PackageInvalid pkg packageProblems + | Configured pkg <- PackageIndex.allPackages index + , let packageProblems = configuredPackageProblems os arch comp pkg + , not (null packageProblems) ] + + ++ [ PackageMissingDeps pkg missingDeps + | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- PackageIndex.dependencyCycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- PackageIndex.allPackages index + , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: PackageIndex PlanPackage -> Bool +acyclic = null . PackageIndex.dependencyCycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: PackageIndex PlanPackage -> Bool +closed = null . PackageIndex.brokenPackages + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are ok so long as they are not both in the transative closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe aproximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: PackageIndex PlanPackage -> Bool +consistent = null . PackageIndex.dependencyInconsistencies + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool +stateDependencyRelation (PreExisting _) (PreExisting _) = True + +stateDependencyRelation (Configured _) (PreExisting _) = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (Configured _) (Installed _ _) = True + +stateDependencyRelation (Installed _ _) (PreExisting _) = True +stateDependencyRelation (Installed _ _) (Installed _ _) = True + +stateDependencyRelation (Failed _ _) (PreExisting _) = True +-- failed can depends on configured because a package can depend on +-- 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 _ _) (Installed _ _) = True +stateDependencyRelation (Failed _ _) (Failed _ _) = True + +stateDependencyRelation _ _ = False + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageValid :: OS -> Arch -> CompilerId -> ConfiguredPackage -> Bool +configuredPackageValid os arch comp pkg = + null (configuredPackageProblems os arch comp pkg) + +data PackageProblem = DuplicateFlag FlagName + | MissingFlag FlagName + | ExtraFlag FlagName + | DuplicateDeps [PackageIdentifier] + | MissingDep Dependency + | ExtraDep PackageIdentifier + | InvalidDep Dependency PackageIdentifier + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag (FlagName flag)) = + "duplicate flag in the flag assignment: " ++ flag + +showPackageProblem (MissingFlag (FlagName flag)) = + "missing an assignment for the flag: " ++ flag + +showPackageProblem (ExtraFlag (FlagName flag)) = + "extra flag given that is not used by the package: " ++ flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map display pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ display dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ display pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ display dep + ++ " but the configuration specifies " ++ display pkgid + ++ " which does not satisfy the dependency." + +configuredPackageProblems :: OS -> Arch -> CompilerId + -> ConfiguredPackage -> [PackageProblem] +configuredPackageProblems os arch comp + (ConfiguredPackage pkg specifiedFlags specifiedDeps) = + [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + where + mergedFlags = mergeBy compare + (sort $ map flagName (genPackageFlags (packageDescription pkg))) + (sort $ map fst specifiedFlags) + + mergedDeps = mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortBy (comparing dependencyName) requiredDeps) + (sortBy (comparing packageName) specifiedDeps) + + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _) = name + + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePackageDescription + case finalizePackageDescription specifiedFlags + (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp [] + (packageDescription pkg) of + Right (resolvedPkg, _) -> buildDepends resolvedPkg + Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,239 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallSymlink +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import Distribution.Package (PackageIdentifier) +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup (InstallFlags) +import Distribution.Simple.Setup (ConfigFlags) + +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries _ _ _ = return [] + +symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" + +#else + +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..) ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Package + ( PackageIdentifier, Package(packageId) ) +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.PackageIndex (PackageIndex) + +import System.Posix.Files + ( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink + , createSymbolicLink, removeLink ) +import System.Directory + ( canonicalizePath ) +import System.FilePath + ( (), takeDirectory, splitPath, joinPath, isAbsolute ) +import System.IO.Error + ( catch, isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) +import Data.Maybe + ( catMaybes ) + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A comprimise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an ok +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on posix systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries configFlags installFlags plan = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequence + [ do privateBinDir <- pkgBinDir pkg + ok <- symlinkBinary + publicBinDir privateBinDir + publicExeName privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (pkg, exe) <- exes + , let publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ publicExeName ++ suffix + pkgid = packageId pkg + prefix = substTemplate pkgid prefixTemplate + suffix = substTemplate pkgid suffixTemplate ] + where + exes = + [ (pkg, exe) + | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan + , let pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription :: ConfiguredPackage -> PackageDescription + pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) = + case finalizePackageDescription flags + (Nothing :: Maybe (PackageIndex PackageDescription)) + os arch compilerId [] pkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> IO FilePath + pkgBinDir pkg = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) compilerId InstallDirs.NoCopyDest + templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compilerId + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + os = InstallPlan.planOS plan + arch = InstallPlan.planArch plan + compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan + +symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir + -- eg @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir + -- eg @/home/user/.cabal/bin@ + -> String -- ^ The name of the executable to go in the public + -- bin dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was sucessful. @False@ + -- if there was another file there already that we + -- did not own. Other errors like permission errors + -- just propagate as exceptions. +symlinkBinary publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) privateBindir + case ok of + NotOurFile -> return False + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink = createSymbolicLink (relativeBindir privateName) + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) + +-- | Check a filepath of a symlink that we would like to create to see if it +-- is ok. For it to be ok to overwrite it must either not already exist yet or +-- be a symlink to our private bin dir (in which case we can assume ownership). +-- +targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private + -- binary that we would like to create + -> FilePath -- ^ The canonical path of the private bin + -- directory. Use 'canonicalizePath'. + -> IO SymlinkStatus +targetOkToOverwrite symlink privateBinDir = handleNotExist $ do + status <- getSymbolicLinkStatus symlink + if not (isSymbolicLink status) + then return NotOurFile + else return + . (\ok -> if ok then OkToOverwrite else NotOurFile) + . (== privateBinDir) + . takeDirectory + =<< canonicalizePath + . (symlink ) + =<< readSymbolicLink symlink + + where + handleNotExist action = catch action $ \ioexception -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first bemore we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ [ b' | b' <- drop commonLen bs ] + +#endif diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/List.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list + ) where + +import Data.List (sortBy, groupBy, sort, nub, intersperse) +import Data.Maybe (listToMaybe, fromJust) +import Control.Monad (MonadPlus(mplus)) +import Control.Exception (assert) + +import Text.PrettyPrint.HughesPJ +import Distribution.Text + ( Text(disp), display ) + +import Distribution.Package (PackageIdentifier(..), Package(..)) +import Distribution.License (License) +import qualified Distribution.PackageDescription as Available +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Version (Version) +import Distribution.Verbosity (Verbosity) + +import Distribution.Client.IndexUtils (getAvailablePackages) +import Distribution.Client.Setup (ListFlags(..)) +import Distribution.Client.Types (AvailablePackage(..), Repo) +import Distribution.Simple.Configure (getInstalledPackages) +import Distribution.Simple.Compiler (Compiler,PackageDB) +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Utils (equating, comparing, notice) +import Distribution.Simple.Setup (fromFlag) + +import Distribution.Client.Utils (mergeBy, MergeResult(..)) + +-- |Show information about packages +list :: Verbosity + -> PackageDB + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ListFlags + -> [String] + -> IO () +list verbosity packageDB repos comp conf listFlags pats = do + Just installed <- getInstalledPackages verbosity comp packageDB conf + available <- getAvailablePackages verbosity repos + let pkgs | null pats = (PackageIndex.allPackages installed + ,PackageIndex.allPackages available) + | otherwise = + (concatMap (PackageIndex.searchByNameSubstring installed) pats + ,concatMap (PackageIndex.searchByNameSubstring available) pats) + matches = installedFilter + . map (uncurry mergePackageInfo) + $ uncurry mergePackages pkgs + + if simpleOutput + then putStr $ unlines + [ name pkg ++ " " ++ display version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ availableVersions pkg ] + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageInfo matches) + where + installedFilter + | onlyInstalled = filter (not . null . installedVersions) + | otherwise = id + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and avilable versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + name :: String, + installedVersions :: [Version], + availableVersions :: [Version], + homepage :: String, + category :: String, + synopsis :: String, + license :: License + } + +showPackageInfo :: PackageDisplayInfo -> String +showPackageInfo pkg = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + text " *" <+> text (name pkg) + $+$ + (nest 6 $ vcat [ + maybeShow (availableVersions pkg) + "Latest version available:" + (disp . maximum) + , maybeShow (installedVersions pkg) + "Latest version installed:" + (disp . maximum) + , maybeShow (homepage pkg) "Homepage:" text + , maybeShow (category pkg) "Category:" text + , maybeShow (synopsis pkg) "Synopsis:" reflowParas + , text "License: " <+> text (show (license pkg)) + ]) + $+$ text "" + where + maybeShow [] _ _ = empty + maybeShow l s f = text s <+> (f l) + reflowParas = vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paras + . filter (/= [""]) + . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: [InstalledPackageInfo] + -> [AvailablePackage] + -> PackageDisplayInfo +mergePackageInfo installed available = + assert (length installed + length available > 0) $ + PackageDisplayInfo { + name = combine (pkgName . packageId) latestAvailable + (pkgName . packageId) latestInstalled, + installedVersions = map (pkgVersion . packageId) installed, + availableVersions = map (pkgVersion . packageId) available, + homepage = combine Available.homepage latestAvailableDesc + Installed.homepage latestInstalled, + category = combine Available.category latestAvailableDesc + Installed.category latestInstalled, + synopsis = combine Available.synopsis latestAvailableDesc + Installed.description latestInstalled, + license = combine Available.license latestAvailableDesc + Installed.license latestInstalled + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + latestInstalled = latestOf installed + latestAvailable = latestOf available + latestAvailableDesc = fmap (Available.packageDescription . packageDescription) + latestAvailable + latestOf :: Package pkg => [pkg] -> Maybe pkg + latestOf = listToMaybe . sortBy (comparing (pkgVersion . packageId)) + +-- | Rearrange installed and available packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [InstalledPackageInfo] -> [AvailablePackage] + -> [([InstalledPackageInfo], [AvailablePackage])] +mergePackages installed available = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn (pkgName . packageId) installed) + (groupOn (pkgName . packageId) available) + where + collect (OnlyInLeft (_,is) ) = (is, []) + collect ( InBoth (_,is) (_,as)) = (is, as) + collect (OnlyInRight (_,as)) = ([], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), xs)) + . groupBy (equating key) + . sortBy (comparing key) diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Setup.hs @@ -0,0 +1,572 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), globalRepos + , configureCommand, Cabal.ConfigFlags(..), filterConfigureFlags, configPackageDB' + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , listCommand, ListFlags(..) + , updateCommand + , upgradeCommand + , infoCommand + , fetchCommand + , checkCommand + , uploadCommand, UploadFlags(..) + , reportCommand + + , parsePackageArgs + --TODO: stop exporting these: + , showRepo + , parseRepo + ) where + +import Distribution.Client.Types + ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) + +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Command hiding (boolOpt) +import qualified Distribution.Simple.Command as Command +import qualified Distribution.Simple.Setup as Cabal + ( ConfigFlags(..), configureCommand ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe, fromFlagOrDefault + , optionVerbosity, trueArg ) +import Distribution.Simple.Compiler + ( PackageDB(..) ) +import Distribution.Version + ( Version(Version), VersionRange(..) ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import Distribution.Text + ( Text(parse), display ) +import Distribution.ReadE + ( readP_to_E, succeedReadE ) +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.Char + ( isSpace, isAlphaNum ) +import Data.Maybe + ( listToMaybe, maybeToList ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( liftM ) +import System.FilePath + ( () ) +import Network.URI + ( parseAbsoluteURI, uriToString ) + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool, + globalConfigFile :: Flag FilePath, + globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers. + globalCacheDir :: Flag FilePath, + globalLocalRepos :: [FilePath] + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandDescription = Just $ \pname -> + "Typical step for installing Cabal packages:\n" + ++ " " ++ pname ++ " install [PACKAGES]\n" + ++ "\nOccasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n" + ++ "\nFor more information about a command, try '" + ++ pname ++ " COMMAND --help'." + ++ "\nThis program is the command line interface to the Haskell Cabal Infrastructure." + ++ "\nSee http://www.haskell.org/cabal/ for more information.\n", + commandUsage = \_ -> [], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \showOrParseArgs -> + (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["local-repo"] + "The location of a local repository" + globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) + (reqArg' "DIR" (\x -> [x]) id) + ] + } + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalRemoteRepos = combine globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = combine globalLocalRepos + } + where combine field = field a `mappend` field b + +globalRepos :: GlobalFlags -> [Repo] +globalRepos globalFlags = remoteRepos ++ localRepos + where + remoteRepos = + [ Repo (Left remote) cacheDir + | remote <- globalRemoteRepos globalFlags + , let cacheDir = fromFlag (globalCacheDir globalFlags) + remoteRepoName remote ] + localRepos = + [ Repo (Right LocalRepo) local + | local <- globalLocalRepos globalFlags ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI Cabal.ConfigFlags +configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +configPackageDB' :: Cabal.ConfigFlags -> PackageDB +configPackageDB' config = + fromFlagOrDefault defaultDB (Cabal.configPackageDB config) + where + defaultDB = case Cabal.configUserInstall config of + NoFlag -> UserPackageDB + Flag True -> UserPackageDB + Flag False -> GlobalPackageDB + +filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags +filterConfigureFlags flags cabalLibVersion + | cabalLibVersion >= Version [1,3,10] [] = flags + -- older Cabal does not grok the constraints flag: + | otherwise = flags { Cabal.configConstraints = [] } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +fetchCommand :: CommandUI (Flag Verbosity) +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation or study.", + commandDescription = Nothing, + commandUsage = usagePackages "fetch", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +updateCommand :: CommandUI (Flag Verbosity) +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Updates list of known packages", + commandDescription = Nothing, + commandUsage = usagePackages "update", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +upgradeCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags) +upgradeCommand = configureCommand { + commandName = "upgrade", + commandSynopsis = "Upgrades installed packages to the latest available version", + commandDescription = Nothing, + commandUsage = usagePackages "upgrade", + commandDefaultFlags = (mempty, defaultInstallFlags), + commandOptions = commandOptions installCommand + } + +{- +cleanCommand :: CommandUI () +cleanCommand = makeCommand name shortDesc longDesc emptyFlags options + where + name = "clean" + shortDesc = "Removes downloaded files" + longDesc = Nothing + emptyFlags = () + options _ = [] +-} + +infoCommand :: CommandUI (Flag Verbosity) +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Emit some info about dependency resolution", + commandDescription = Nothing, + commandUsage = usagePackages "info", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", + commandDefaultFlags = toFlag normal, + commandOptions = mempty + } + +reportCommand :: CommandUI (Flag Verbosity) +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " report\n", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags { + listInstalled :: Flag Bool, + listSimpleOutput :: Flag Bool, + listVerbosity :: Flag Verbosity + } + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listInstalled = Flag False, + listSimpleOutput = Flag False, + listVerbosity = toFlag normal + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List available packages on the server (cached).", + commandDescription = Nothing, + commandUsage = usagePackages "list", + commandDefaultFlags = defaultListFlags, + commandOptions = \_ -> [ + optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + + ] + } + +instance Monoid ListFlags where + mempty = defaultListFlags + mappend a b = ListFlags { + listInstalled = combine listInstalled, + listSimpleOutput = combine listSimpleOutput, + listVerbosity = combine listVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation:: Flag Bool, + installDryRun :: Flag Bool, + installReinstall :: Flag Bool, + installOnly :: Flag Bool, + installRootCmd :: Flag String, + installCabalVersion :: Flag Version, + installLogFile :: Flag FilePath, + installBuildReports :: Flag Bool, + installSymlinkBinDir:: Flag FilePath + } + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation= Flag False, + installDryRun = Flag False, + installReinstall = Flag False, + installOnly = Flag False, + installRootCmd = mempty, + installCabalVersion = mempty, + installLogFile = mempty, + installBuildReports = Flag False, + installSymlinkBinDir= mempty + } + +installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags) +installCommand = configureCommand { + commandName = "install", + commandSynopsis = "Installs a list of packages.", + commandUsage = usagePackages "install", + commandDefaultFlags = (mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++ + liftOptionsSnd (installOptions showOrParseArgs) + } + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + trueArg + + , option [] ["root-cmd"] + "Command used to gain root privileges, when installing with --global." + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + installCabalVersion (\v flags -> flags { installCabalVersion = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) + (fmap toFlag parse)) + (map display . flagToList)) + + , option [] ["log-builds"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "FILE" toFlag flagToList) + + , option [] ["build-reports"] + "Generate detailed build reports. (overrides --log-builds)" + installBuildReports (\v flags -> flags { installBuildReports = v }) + trueArg + + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids + ParseArgs -> + option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg + : [] + _ -> [] + +instance Monoid InstallFlags where + mempty = InstallFlags { + installDocumentation= mempty, + installDryRun = mempty, + installReinstall = mempty, + installOnly = mempty, + installRootCmd = mempty, + installCabalVersion = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir= mempty + } + mappend a b = InstallFlags { + installDocumentation= combine installDocumentation, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installOnly = combine installOnly, + installRootCmd = combine installRootCmd, + installCabalVersion = combine installCabalVersion, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir= combine installSymlinkBinDir + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +data UploadFlags = UploadFlags { + uploadCheck :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadVerbosity :: Flag Verbosity + } + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCheck = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages to Hackage", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) + + ,option ['c'] ["check"] + "Do not upload, just do QA checks." + uploadCheck (\v flags -> flags { uploadCheck = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid UploadFlags where + mempty = UploadFlags { + uploadCheck = mempty, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = mempty + } + mappend a b = UploadFlags { + uploadCheck = combine uploadCheck, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadVerbosity = combine uploadVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptionsFst :: [OptionField a] -> [OptionField (a,b)] +liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b))) + +liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)] +liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b))) + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +--TODO: do we want to allow per-package flags? +parsePackageArgs :: [String] -> Either String [Dependency] +parsePackageArgs = parsePkgArgs [] + where + parsePkgArgs ds [] = Right (reverse ds) + parsePkgArgs ds (arg:args) = + case readPToMaybe parseDependencyOrPackageId arg of + Just dep -> parsePkgArgs (dep:ds) args + Nothing -> Left ("Failed to parse package dependency: " ++ show arg) + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + +parseDependencyOrPackageId :: Parse.ReadP r Dependency +parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse + where + pkgidToDependency :: PackageIdentifier -> Dependency + pkgidToDependency p = case packageVersion p of + Version [] _ -> Dependency (packageName p) AnyVersion + version -> Dependency (packageName p) (ThisVersion version) + +showRepo :: RemoteRepo -> String +showRepo repo = remoteRepoName repo ++ ":" + ++ uriToString id (remoteRepoURI repo) [] + +readRepo :: String -> Maybe RemoteRepo +readRepo = readPToMaybe parseRepo + +parseRepo :: Parse.ReadP r RemoteRepo +parseRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + Parse.char ':' + uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") + uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) + return $ RemoteRepo { + remoteRepoName = name, + remoteRepoURI = uri + } diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,328 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version(..), VersionRange(..), withinRange ) +import Distribution.Package + ( PackageIdentifier(..), Package(..), packageName, packageVersion + , Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), BuildType(..), readPackageDescription ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.Configure + ( configCompiler, getInstalledPackages ) +import Distribution.Simple.Compiler + ( CompilerFlavor(GHC), Compiler, PackageDB(..) ) +import Distribution.Simple.Program + ( ProgramConfiguration, emptyProgramConfiguration + , rawSystemProgramConf, ghcProgram ) +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.GHC + ( ghcVerbosityOptions ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Utils + ( die, debug, info, cabalVersion, findPackageDesc, comparing + , createDirectoryIfMissingVerbose, inDir ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory ( doesFileExist, getModificationTime, getCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO.Error ( isDoesNotExistError ) +import System.IO ( Handle ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Process ( runProcess, waitForProcess ) +import Control.Monad ( when, unless ) +import Control.Exception ( evaluate ) +import Data.List ( maximumBy ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Monoid ( Monoid(mempty) ) +import Data.Char ( isSpace ) + +data SetupScriptOptions = SetupScriptOptions { + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageIndex :: Maybe (PackageIndex InstalledPackageInfo), + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = AnyVersion, + useCompiler = Nothing, + usePackageIndex = Nothing, + useProgramConfig = emptyProgramConfiguration, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -> [String] + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + pkg <- maybe getPkg return mpkg + let setupMethod = determineSetupMethod options' buildType' + options' = options { + useCabalVersion = IntersectVersionRanges + (useCabalVersion options) + (descCabalVersion pkg) + } + buildType' = fromMaybe Custom (buildType pkg) + mkArgs cabalLibVersion = commandName cmd + : commandShowOptions cmd (flags cabalLibVersion) + ++ extraArgs + setupMethod verbosity options' (packageId pkg) buildType' mkArgs + where + getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) + >>= readPackageDescription verbosity + >>= return . packageDescription + +-- | Decide if we're going to be able to do a direct internal call to the +-- entry point in the Cabal library or if we're going to have to compile +-- and execute an external Setup.hs script. +-- +determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod +determineSetupMethod options buildType' + | isJust (useLoggingHandle options) + || buildType' == Custom = externalSetupMethod + | cabalVersion `withinRange` + useCabalVersion options = internalSetupMethod + | otherwise = externalSetupMethod + +type SetupMethod = Verbosity + -> SetupScriptOptions + -> PackageIdentifier + -> BuildType + -> (Version -> [String]) -> IO () + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupMethod +internalSetupMethod verbosity options _ bt mkargs = do + let args = mkargs cabalVersion + debug verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" +buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: SetupMethod +externalSetupMethod verbosity options pkg bt mkargs = do + debug verbosity $ "Using external setup method with build-type " ++ show bt + createDirectoryIfMissingVerbose verbosity True setupDir + (cabalLibVersion, options') <- cabalLibVersionToUse + 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) + + where + workingDir = fromMaybe "" (useWorkingDir options) + setupDir = workingDir useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + + cabalLibVersionToUse :: IO (Version, SetupScriptOptions) + cabalLibVersionToUse = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version | version `withinRange` useCabalVersion options + -> return (version, options) + _ -> do (comp, conf, options') <- configureCompiler options + version <- installedCabalVersion options comp conf + writeFile setupVersionFile (show version ++ "\n") + return (version, options') + + savedCabalVersion = do + versionString <- readFile setupVersionFile `catch` \_ -> return "" + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion :: SetupScriptOptions -> Compiler + -> ProgramConfiguration -> IO Version + installedCabalVersion _ _ _ | packageName pkg == "Cabal" = + return (packageVersion pkg) + installedCabalVersion options' comp conf = do + index <- case usePackageIndex options' of + Just index -> return index + Nothing -> fromMaybe mempty + `fmap` getInstalledPackages verbosity comp UserPackageDB conf + -- user packages are *allowed* here, no portability problem + + let cabalDep = Dependency "Cabal" (useCabalVersion options) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map packageVersion pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + configureCompiler :: SetupScriptOptions + -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) + configureCompiler options' = do + (comp, conf) <- case useCompiler options' of + Just comp -> return (comp, useProgramConfig options') + Nothing -> configCompiler (Just GHC) Nothing Nothing + (useProgramConfig options') verbosity + return (comp, conf, options' { useCompiler = Just comp, + useProgramConfig = conf }) + + -- | Decide which Setup.hs script to use, creating it if necessary. + -- + updateSetupScript :: Version -> BuildType -> IO FilePath + updateSetupScript _ Custom = do + useHs <- doesFileExist setupHs + useLhs <- doesFileExist setupLhs + unless (useHs || useLhs) $ die + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + return (if useHs then setupHs else setupLhs) + where + setupHs = workingDir "Setup.hs" + setupLhs = workingDir "Setup.lhs" + + updateSetupScript cabalLibVersion _ = do + rewriteFile setupHs (buildTypeScript cabalLibVersion) + return setupHs + where + setupHs = setupDir "setup.hs" + + buildTypeScript :: Version -> String + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure -> "import Distribution.Simple; main = defaultMainWithHooks " + ++ if cabalLibVersion >= Version [1,3,10] [] + then "autoconfUserHooks\n" + else "defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + + -- | 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 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' + rawSystemProgramConf verbosity ghcProgram conf $ + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir] + ++ if packageName pkg == "Cabal" + then ["-i", "-i."] + else ["-i", "-package", display cabalPkgid ] + where cabalPkgid = PackageIdentifier "Cabal" cabalLibVersion + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + currentDir <- getCurrentDirectory + process <- runProcess (currentDir setupProgFile) args + (useWorkingDir options) Nothing + Nothing (useLoggingHandle options) (useLoggingHandle options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catch mightNotExist $ do + existingContent <- readFile path + evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFile path newContent + where + mightNotExist e | isDoesNotExistError e = writeFile path newContent + | otherwise = ioError e diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SrcDist.hs @@ -0,0 +1,80 @@ +-- Implements the \"@.\/cabal sdist@\" command, which creates a source +-- distribution for this package. That is, packs up the source code +-- into a tarball, making use of the corresponding Cabal module. +module Distribution.Client.SrcDist ( + sdist + ) where +import Distribution.Simple.SrcDist + ( printPackageProblems, prepareTree, prepareSnapshotTree ) +import Distribution.Client.Tar (createTarGzFile) + +import Distribution.Package + ( Package(..) ) +import Distribution.PackageDescription + ( PackageDescription, readPackageDescription ) +import Distribution.Simple.Utils + ( withTempDirectory , defaultPackageDesc + , die, warn, notice, setupMessage ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Configure(maybeGetPersistBuildConfig) +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Text + ( display ) + +import System.Time (getClockTime, toCalendarTime) +import System.FilePath ((), (<.>)) +import System.Directory (doesDirectoryExist) +import Control.Monad (when) +import Data.Maybe (isNothing) + +-- |Create a source distribution. +sdist :: SDistFlags -> IO () +sdist flags = do + pkg <- return . flattenPackageDescription + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + mb_lbi <- maybeGetPersistBuildConfig distPref + let tmpDir = srcPref distPref + + -- do some QA + printPackageProblems verbosity pkg + + exists <- doesDirectoryExist tmpDir + when exists $ + die $ "Source distribution already in place. please move or remove: " + ++ tmpDir + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + withTempDirectory verbosity tmpDir $ do + + setupMessage verbosity "Building source dist for" (packageId pkg) + if snapshot + then getClockTime >>= toCalendarTime + >>= prepareSnapshotTree verbosity pkg mb_lbi + distPref tmpDir knownSuffixHandlers + else prepareTree verbosity pkg mb_lbi + distPref tmpDir knownSuffixHandlers + targzFile <- createArchive verbosity pkg tmpDir distPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + distPref = fromFlag (sDistDistPref flags) + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity + -> PackageDescription + -> FilePath + -> FilePath + -> IO FilePath +createArchive _verbosity pkg tmpDir targetPref = do + let tarBallName = display (packageId pkg) + tarBallFilePath = targetPref tarBallName <.> "tar.gz" + createTarGzFile tarBallFilePath tmpDir tarBallName + return tarBallFilePath diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Tar.hs @@ -0,0 +1,721 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- TAR archive reading and writing +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * High level all in one operations on files + createTarGzFile, + extractTarGzFile, + + -- * Reading and writing the tar format + read, + write, + + -- * Packing and unpacking files to\/from a tar archive + pack, + unpack, + + -- * Tar archive 'Entry' + Entry(..), fileName, + ExtendedHeader(..), + FileType(..), + UserId, + GroupId, + EpochTime, + DevMajor, + DevMinor, + FileSize, + + -- ** Constructing entries + emptyEntry, + simpleFileEntry, + simpleDirectoryEntry, + + -- ** 'TarPath's + TarPath, + toTarPath, + fromTarPath, + + -- * Sequence of 'Entry' records with failures + Entries(..), + foldEntries, + unfoldEntries, + mapEntries, + + -- * Sanity checking tar contents + checkEntryNames + ) where + +import Data.Char (ord) +import Data.Int (Int64) +import Data.List (foldl') +import Data.Monoid (Monoid(..)) +import Numeric (readOct, showOct) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip + +import System.FilePath + ( () ) +import qualified System.FilePath as FilePath.Native + ( (), joinPath, splitDirectories, takeDirectory + , isAbsolute, isValid, makeRelative ) +import qualified System.FilePath.Posix as FilePath.Posix + ( joinPath, pathSeparator, splitPath, splitDirectories ) +import System.Directory + ( getDirectoryContents, doesDirectoryExist + , getModificationTime, createDirectoryIfMissing, copyFile + , Permissions(..), getPermissions ) +import System.Posix.Types + ( FileMode ) +import System.Time + ( ClockTime(..) ) +import System.IO + ( IOMode(ReadMode), openBinaryFile, hFileSize ) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Distribution.Client.Utils + ( writeFileAtomic ) + +import Prelude hiding (read) + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = + writeFileAtomic tar . GZip.compress . write =<< pack base dir + +extractTarGzFile :: FilePath -- ^ Destination directory + -> FilePath -- ^ Tarball + -> IO () +extractTarGzFile dir tar = + unpack dir . checkEntryNames . read . GZip.decompress =<< BS.readFile tar + +-- +-- * Entry type +-- + +type UserId = Int +type GroupId = Int +type EpochTime = Int -- ^ The number of seconds since the UNIX epoch +type DevMajor = Int +type DevMinor = Int +type FileSize = Int64 + +-- | TAR archive entry +data Entry = Entry { + + -- | Path of the file or directory. The path separator should be @/@ for + -- portable TAR archives. + filePath :: TarPath, + + -- | UNIX file mode. + fileMode :: FileMode, + + -- | Numeric owner user id. Should be set to @0@ if unknown. + ownerId :: UserId, + + -- | Numeric owner group id. Should be set to @0@ if unknown. + groupId :: GroupId, + + -- | File size in bytes. Should be 0 for entries other than normal files. + fileSize :: FileSize, + + -- | Last modification time. + modTime :: EpochTime, + + -- | Type of this entry. + fileType :: FileType, + + -- | If the entry is a hard link or a symbolic link, this is the path of + -- the link target. For all other entry types this should be @\"\"@. + linkTarget :: FilePath, + + -- | The remaining meta-data is in the V7, ustar/posix or gnu formats + -- For V7 there is no extended info at all and for posix/ustar the + -- information is the same though the kind affects the way the information + -- is encoded. + headerExt :: ExtendedHeader, + + -- | Entry contents. For entries other than normal + -- files, this should be an empty string. + fileContent :: ByteString + } + +fileName :: Entry -> FilePath +fileName = fromTarPath . filePath + +data ExtendedHeader + = V7 + | USTAR { + -- | The owner user name. Should be set to @\"\"@ if unknown. + ownerName :: String, + + -- | The owner group name. Should be set to @\"\"@ if unknown. + groupName :: String, + + -- | For character and block device entries, this is the + -- major number of the device. For all other entry types, it + -- should be set to @0@. + deviceMajor :: DevMajor, + + -- | For character and block device entries, this is the + -- minor number of the device. For all other entry types, it + -- should be set to @0@. + deviceMinor :: DevMinor + } + | GNU { + -- | The owner user name. Should be set to @\"\"@ if unknown. + ownerName :: String, + + -- | The owner group name. Should be set to @\"\"@ if unknown. + groupName :: String, + + -- | For character and block device entries, this is the + -- major number of the device. For all other entry types, it + -- should be set to @0@. + deviceMajor :: DevMajor, + + -- | For character and block device entries, this is the + -- minor number of the device. For all other entry types, it + -- should be set to @0@. + deviceMinor :: DevMinor + } + +-- | TAR archive entry types. +data FileType = NormalFile + | HardLink + | SymbolicLink + | CharacterDevice + | BlockDevice + | Directory + | FIFO + | ExtendedHeader + | GlobalHeader + | Custom Char -- 'A' .. 'Z' + | Reserved Char -- other / reserved / unknown + deriving (Eq, Show) + +toFileTypeCode :: FileType -> Char +toFileTypeCode NormalFile = '0' +toFileTypeCode HardLink = '1' +toFileTypeCode SymbolicLink = '2' +toFileTypeCode CharacterDevice = '3' +toFileTypeCode BlockDevice = '4' +toFileTypeCode Directory = '5' +toFileTypeCode FIFO = '6' +toFileTypeCode ExtendedHeader = 'x' +toFileTypeCode GlobalHeader = 'g' +toFileTypeCode (Custom c) = c +toFileTypeCode (Reserved c) = c + +fromFileTypeCode :: Char -> FileType +fromFileTypeCode '0' = NormalFile +fromFileTypeCode '\0' = NormalFile +fromFileTypeCode '1' = HardLink +fromFileTypeCode '2' = SymbolicLink +fromFileTypeCode '3' = CharacterDevice +fromFileTypeCode '4' = BlockDevice +fromFileTypeCode '5' = Directory +fromFileTypeCode '6' = FIFO +fromFileTypeCode '7' = NormalFile +fromFileTypeCode 'x' = ExtendedHeader +fromFileTypeCode 'g' = GlobalHeader +fromFileTypeCode c | c >= 'A' && c <= 'Z' + = Custom c +fromFileTypeCode c = Reserved c + +emptyEntry :: FileType -> TarPath -> Entry +emptyEntry ftype tarpath = Entry { + filePath = tarpath, + fileMode = case ftype of + Directory -> 0o0755 -- rwxr-xr-x for directories + _ -> 0o0644, -- rw-r--r-- for normal files + ownerId = 0, + groupId = 0, + fileSize = 0, + modTime = 0, + fileType = ftype, + linkTarget = "", + headerExt = USTAR { + ownerName = "", + groupName = "", + deviceMajor = 0, + deviceMinor = 0 + }, + fileContent = BS.empty + } + +simpleFileEntry :: TarPath -> ByteString -> Entry +simpleFileEntry name content = (emptyEntry NormalFile name) { + fileSize = BS.length content, + fileContent = content + } + +simpleDirectoryEntry :: TarPath -> Entry +simpleDirectoryEntry name = emptyEntry Directory name + +-- +-- * Tar paths +-- + +-- | The classic tar format allowed just 100 charcters 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 +-- prefix (if any) must only contain a directory prefix. That is the split +-- between the two areas must be on a directory separator boundary. So there is +-- no simple calculation to work out if a file name is too long. Instead we +-- have to try to find a valid split that makes the name fit in the two areas. +-- +-- The rationale presumably was to make it a bit more compatible with tar +-- programs that only understand the classic format. A classic tar would be +-- able to extract the file name and possibly some dir prefix, but not the +-- full dir prefix. So the files would end up in the wrong place, but that's +-- probably better than ending up with the wrong names too. +-- +-- So it's understandable but rather annoying. +-- +-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective +-- of the local path conventions. +-- +-- * The directory separator between the prefix and name is /not/ stored. +-- +data TarPath = TarPath FilePath -- path name, 100 characters max. + FilePath -- path prefix, 155 characters max. + +-- | Convert a 'TarPath' to a native 'FilePath'. +-- +-- The native 'FilePath' will use the native directory separator but it is not +-- otherwise checked for validity or sanity. In particular: +-- +-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is +-- not valid on Windows. +-- * The tar path may be an absolute path or may contain @\"..\"@ components. +-- For security reasons this should not usually be allowed, but it is your +-- responsibility to check for these conditions. +-- +fromTarPath :: TarPath -> FilePath +fromTarPath (TarPath name prefix) = + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix + ++ FilePath.Posix.splitDirectories name + +-- | Convert a native 'FilePath' to a 'TarPath'. The 'FileType' is needed +-- because for directories a 'TarPath' uses a trailing @\/@. +-- +-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a +-- description of the problem with splitting long 'FilePath's. +-- +toTarPath :: FileType -> FilePath -> Either String TarPath +toTarPath ftype = splitLongPath + . addTrailingSep ftype + . FilePath.Posix.joinPath + . FilePath.Native.splitDirectories + where + addTrailingSep Directory path = path ++ [FilePath.Posix.pathSeparator] + addTrailingSep _ path = path + +-- | Takes a sanitized path, split on directory separators and tries to pack it +-- into the 155 + 100 tar file name format. +-- +-- The stragey is this: take the name-directory components in reverse order +-- and try to fit as many components into the 100 long name area as possible. +-- If all the remaining components fit in the 155 name area then we win. +-- +splitLongPath :: FilePath -> Either String TarPath +splitLongPath path = + case packName nameMax (reverse (FilePath.Posix.splitPath path)) of + Left err -> Left err + Right (name, []) -> Right (TarPath name "") + Right (name, first:rest) -> case packName prefixMax remainder of + Left err -> Left err + Right (_ , (_:_)) -> Left "File name too long (cannot split)" + Right (prefix, []) -> Right (TarPath name prefix) + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + packName _ [] = Left "File name empty" + packName maxLen (c:cs) + | n > maxLen = Left "File name too long" + | otherwise = Right (packName' maxLen n [c] cs) + where n = length c + + packName' maxLen n ok (c:cs) + | n' <= maxLen = packName' maxLen n' (c:ok) cs + where n' = n + length c + packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) + +-- +-- * Entries type +-- + +-- | A tar archive is a sequence of entries. +data Entries = Next Entry Entries + | Done + | Fail String + +unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries +unfoldEntries f = unfold + where + unfold x = case f x of + Left err -> Fail err + Right Nothing -> Done + Right (Just (e, x')) -> Next e (unfold x') + +foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a +foldEntries next done fail' = fold + where + fold (Next e es) = next e (fold es) + fold Done = done + fold (Fail err) = fail' err + +mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries +mapEntries f = + foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail + +-- +-- * Checking +-- + +checkEntryNames :: Entries -> Entries +checkEntryNames = + mapEntries (\entry -> maybe (Right entry) Left (checkEntryName entry)) + +checkEntryName :: Entry -> Maybe String +checkEntryName entry = case fileType entry of + HardLink -> check (fileName entry) `mappend` check (linkTarget entry) + SymbolicLink -> check (fileName entry) `mappend` check (linkTarget entry) + _ -> check (fileName entry) + + where + check name + | FilePath.Native.isAbsolute name + = Just $ "Absolute file name in tar archive: " ++ show name + | not (FilePath.Native.isValid name) + = Just $ "Invalid file name in tar archive: " ++ show name + | any (=="..") (FilePath.Native.splitDirectories name) + = Just $ "Invalid file name in tar archive: " ++ show name + | otherwise = Nothing + +-- +-- * Reading +-- + +read :: ByteString -> Entries +read = unfoldEntries getEntry + +getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry bs + | BS.length header < 512 = Left "Truncated TAR archive" + | endBlock = Right Nothing --FIXME: force last two blocks to close fds! + | not (correctChecksum header chksum) = Left "TAR checksum error" + | magic /= "ustar\NUL00" + && magic /= "ustar \NUL" = Left $ "TAR entry not ustar format: " ++ show magic + | otherwise = Right (Just (entry, bs''')) + where + (header,bs') = BS.splitAt 512 bs + + endBlock = getByte 0 header == '\0' + + name = getString 0 100 header + mode = getOct 100 8 header + uid = getOct 108 8 header + gid = getOct 116 8 header + size = getOct 124 12 header + mtime = getOct 136 12 header + chksum = getOct 148 8 header + typecode = getByte 156 header + linkname = getString 157 100 header + magic = getChars 257 8 header + uname = getString 265 32 header + gname = getString 297 32 header + devmajor = getOct 329 8 header + devminor = getOct 337 8 header + prefix = getString 345 155 header +-- trailing = getBytes 500 12 header --TODO: check all \0's + + padding = (512 - size) `mod` 512 + (cnt,bs'') = BS.splitAt size bs' + bs''' = BS.drop padding bs'' + + entry = Entry { + filePath = TarPath name prefix, + fileMode = mode, + ownerId = uid, + groupId = gid, + fileSize = size, + modTime = mtime, + fileType = fromFileTypeCode typecode, + linkTarget = linkname, + headerExt = case magic of + "\0\0\0\0\0\0\0\0" -> V7 + "ustar\NUL00" -> USTAR { + ownerName = uname, + groupName = gname, + deviceMajor = devmajor, + deviceMinor = devminor + } + "ustar \NUL" -> GNU { + ownerName = uname, + groupName = gname, + deviceMajor = devmajor, + deviceMinor = devminor + } + _ -> V7, --FIXME: fail instead + fileContent = cnt + } + +correctChecksum :: ByteString -> Int -> Bool +correctChecksum header checksum = checksum == checksum' + where + -- sum of all 512 bytes in the header block, + -- treating each byte as an 8-bit unsigned value + checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' + -- treating the 8 bytes of chksum as blank characters. + header' = BS.concat [BS.take 148 header, + BS.Char8.replicate 8 ' ', + BS.drop 156 header] + +-- * TAR format primitive input + +getOct :: Integral a => Int64 -> Int64 -> ByteString -> a +getOct off len = parseOct + . BS.Char8.unpack + . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') + . getBytes off len + where + parseOct "" = 0 + parseOct s = case readOct s of + [(x,[])] -> x + _ -> error $ "Number format error: " ++ show s + +getBytes :: Int64 -> Int64 -> ByteString -> ByteString +getBytes off len = BS.take len . BS.drop off + +getByte :: Int64 -> ByteString -> Char +getByte off bs = BS.Char8.index bs off + +getChars :: Int64 -> Int64 -> ByteString -> String +getChars off len = BS.Char8.unpack . getBytes off len + +getString :: Int64 -> Int64 -> ByteString -> String +getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len + +-- +-- * Writing +-- + +-- | Creates an uncompressed archive +write :: [Entry] -> ByteString +write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] + +putEntry :: Entry -> ByteString +putEntry entry = BS.concat [ header, content, padding ] + where + header = putHeader entry + content = fileContent entry + padding = BS.replicate paddingSize 0 + paddingSize = fromIntegral $ negate (fileSize entry) `mod` 512 + +putHeader :: Entry -> BS.ByteString +putHeader entry = + BS.Char8.pack $ take 148 block + ++ putOct 7 checksum + ++ ' ' : drop 156 block + where + block = putHeaderNoChkSum entry + checksum = foldl' (\x y -> x + ord y) 0 block + +putHeaderNoChkSum :: Entry -> String +putHeaderNoChkSum entry = concat + [ putString 100 $ name + , putOct 8 $ fileMode entry + , putOct 8 $ ownerId entry + , putOct 8 $ groupId entry + , putOct 12 $ fileSize entry + , putOct 12 $ modTime entry + , fill 8 $ ' ' -- dummy checksum + , putChar8 $ toFileTypeCode (fileType entry) + , putString 100 $ linkTarget entry + ] ++ + case headerExt entry of + V7 -> + fill 255 '\NUL' + ext@USTAR {}-> concat + [ putString 8 $ "ustar\NUL00" + , putString 32 $ ownerName ext + , putString 32 $ groupName ext + , putOct 8 $ deviceMajor ext + , putOct 8 $ deviceMinor ext + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + ext@GNU {} -> concat + [ putString 8 $ "ustar \NUL" + , putString 32 $ ownerName ext + , putString 32 $ groupName ext + , putGnuDev 8 $ deviceMajor ext + , putGnuDev 8 $ deviceMinor ext + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + where + TarPath name prefix = filePath entry + putGnuDev w n = case fileType entry of + CharacterDevice -> putOct w n + BlockDevice -> putOct w n + _ -> replicate w '\NUL' + + +-- * TAR format primitive output + +type FieldWidth = Int + +putString :: FieldWidth -> String -> String +putString n s = take n s ++ fill (n - length s) '\NUL' + +putOct :: Integral a => FieldWidth -> a -> String +putOct n x = + let octStr = take (n-1) $ showOct x "" + in fill (n - length octStr - 1) '0' + ++ octStr + ++ putChar8 '\NUL' + +putChar8 :: Char -> String +putChar8 c = [c] + +fill :: FieldWidth -> Char -> String +fill n c = replicate n c + +-- +-- * Unpacking +-- + +unpack :: FilePath -> Entries -> IO () +unpack dir entries = extractLinks =<< extractFiles [] entries + where + extractFiles _ (Fail err) = Prelude.fail err + extractFiles links Done = return links + extractFiles links (Next entry entries') = case fileType entry of + NormalFile -> BS.writeFile (dir fileName entry) (fileContent entry) + >> extractFiles links entries' + HardLink -> saveLink + SymbolicLink -> saveLink + Directory -> createDirectoryIfMissing False (dir fileName entry) + >> extractFiles links entries' + _ -> extractFiles links entries' -- FIXME: warning? + where + saveLink = seq (length name) + $ seq (length name) + $ extractFiles (link:links) entries' + where + name = fileName entry + target = linkTarget entry + link = (name, target) + + extractLinks = mapM_ $ \(name, target) -> + let path = dir name + in copyFile (FilePath.Native.takeDirectory path target) path + +-- +-- * Packing +-- + +-- | Creates a tar archive from a directory of files, the paths in the archive +-- will be relative to the given base directory. +-- +pack :: FilePath -- ^ Base directory + -> FilePath -- ^ Directory or file to package, relative to the base dir + -> IO [Entry] +pack baseDir sourceDir = + mapM (unsafeInterleaveIO . uncurry (createFileEntry baseDir)) + =<< recurseDirectories [baseDir sourceDir] + +recurseDirectories :: [FilePath] -> IO [(FileType, FilePath)] +recurseDirectories [] = return [] +recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents dir + + files' <- recurseDirectories (dirs' ++ dirs) + return ((Directory, dir) : map ((,) NormalFile) files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist dirEntry + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +createFileEntry :: FilePath -- ^ path to find the file + -> FileType + -> FilePath -- ^ path to use for the tar Entry + -> IO Entry +createFileEntry baseDir ftype absPath = do + let relPath = FilePath.Native.makeRelative baseDir absPath + tarpath <- either Prelude.fail return (toTarPath ftype relPath) + mtime <- getModTime absPath + + case ftype of + NormalFile -> do + file <- openBinaryFile absPath ReadMode + mode <- getFileMode absPath + size <- hFileSize file + content <- BS.hGetContents file + return (emptyEntry NormalFile tarpath) { + fileMode = mode, + modTime = mtime, + fileSize = fromIntegral size, + fileContent = content + } + _ -> + return (emptyEntry Directory tarpath) { + modTime = mtime + } + +-- | We can't be precise because of portability, so we default to rw-r--r-- for +-- normal filesand rwxr-xr-x for executables. +getFileMode :: FilePath -> IO FileMode +getFileMode path = do + perms <- getPermissions path + if executable perms + then return 0o0755 + else return 0o0644 + +getModTime :: FilePath -> IO EpochTime +getModTime path = + do (TOD s _) <- getModificationTime path + return (fromIntegral s) diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Types.hs @@ -0,0 +1,110 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files. +----------------------------------------------------------------------------- +module Distribution.Client.Types where + +import Distribution.Package + ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) + , Dependency ) +import Distribution.PackageDescription + ( GenericPackageDescription, FlagAssignment ) + +import Network.URI (URI) +import Control.Exception + ( Exception ) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +data ConfiguredPackage = ConfiguredPackage + AvailablePackage -- package info, including repo + FlagAssignment -- complete flag assignment for the package + [PackageIdentifier] -- set of exact dependencies. These must be + -- consistent with the 'buildDepends' in the + -- 'PackageDescrption' that you'd get by applying + -- the flag assignment. + deriving Show + +instance Package ConfiguredPackage where + packageId (ConfiguredPackage pkg _ _) = packageId pkg + +instance PackageFixedDeps ConfiguredPackage where + depends (ConfiguredPackage _ _ deps) = deps + + +-- | We re-use @GenericPackageDescription@ and use the @package-url@ +-- field to store the tarball URI. +data AvailablePackage = AvailablePackage { + packageInfoId :: PackageIdentifier, + packageDescription :: GenericPackageDescription, + packageSource :: AvailablePackageSource + } + deriving Show + +instance Package AvailablePackage where packageId = packageInfoId + +data AvailablePackageSource = + + -- | The unpacked package in the current dir + LocalUnpackedPackage + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo + +-- | ScmPackage + deriving Show + +--TODO: +-- * generalise local package to any local unpacked package, not just in the +-- current dir, ie add a FilePath param +-- * add support for darcs and other SCM style remote repos with a local cache + +data LocalRepo = LocalRepo + deriving (Show,Eq) + +data RemoteRepo = RemoteRepo { + remoteRepoName :: String, + remoteRepoURI :: URI + } + deriving (Show,Eq) + +data Repo = Repo { + repoKind :: Either RemoteRepo LocalRepo, + repoLocalDir :: FilePath + } + deriving (Show,Eq) + +data UnresolvedDependency + = UnresolvedDependency + { dependency :: Dependency + , depFlags :: FlagAssignment + } + deriving (Show) + +type BuildResult = Either BuildFailure BuildSuccess +data BuildFailure = DependentFailed PackageIdentifier + | UnpackFailed Exception + | ConfigureFailed Exception + | BuildFailed Exception + | InstallFailed Exception +data BuildSuccess = BuildOk DocsResult TestsResult + +data DocsResult = DocsNotTried | DocsFailed | DocsOk +data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Update.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Update +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Update + ( update + ) where + +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.Fetch + ( downloadIndex ) +import qualified Distribution.Client.Utils as BS + ( writeFileAtomic ) + +import Distribution.Simple.Utils (notice) +import Distribution.Verbosity (Verbosity) + +import qualified Data.ByteString.Lazy as BS +import qualified Codec.Compression.GZip as GZip (decompress) +import System.FilePath (dropExtension) + +-- | 'update' downloads the package list from all known servers +update :: Verbosity -> [Repo] -> IO () +update verbosity = mapM_ (updateRepo verbosity) + +updateRepo :: Verbosity -> Repo -> IO () +updateRepo verbosity repo = case repoKind repo of + Right LocalRepo -> return () + Left remoteRepo -> do + notice verbosity $ "Downloading package list from server '" + ++ show (remoteRepoURI remoteRepo) ++ "'" + indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) + BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress + =<< BS.readFile indexPath diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Upload.hs @@ -0,0 +1,170 @@ +-- This is a quick hack for uploading packages to Hackage. +-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload + +module Distribution.Client.Upload (check, upload, report) where + +import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) +import Distribution.Client.HttpUtils (proxy, isOldHackageURI) + +import Distribution.Simple.Utils (debug, notice, warn, info) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.Browser + ( BrowserAction, browse, request + , Authority(..), addAuthority, setAuthorityGen + , setOutHandler, setErrHandler, setProxy ) +import Network.HTTP + ( Header(..), HeaderName(..), findHeader + , Request(..), RequestMethod(..), Response(..) ) +import Network.URI (URI(uriPath), parseURI) + +import Data.Char (intToDigit) +import Numeric (showHex) +import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho + ,openBinaryFile, IOMode(ReadMode), hGetContents) +import Control.Exception (bracket) +import System.Random (randomRIO) +import System.FilePath ((), takeExtension) +import qualified System.FilePath.Posix as FilePath.Posix (combine) +import System.Directory +import Control.Monad (forM_) + + +--FIXME: how do we find this path for an arbitrary hackage server? +-- is it always at some fixed location relative to the server root? +legacyUploadURI :: URI +Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" + +checkURI :: URI +Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" + + +upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () +upload verbosity repos mUsername mPassword paths = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + 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 + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + promptUsername :: IO Username + promptUsername = do + putStr "Hackage username: " + hFlush stdout + fmap Username getLine + + promptPassword :: IO Password + promptPassword = do + putStr "Hackage password: " + hFlush stdout + -- save/restore the terminal echoing status + bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False -- no echoing for entering the password + fmap Password getLine + +report :: Verbosity -> [Repo] -> IO () +report verbosity repos + = forM_ repos $ \repo -> + case repoKind repo of + Left remoteRepo + -> do dotCabal <- defaultCabalDir + let srcDir = dotCabal "reports" remoteRepoName remoteRepo + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) + case BuildReport.parse reportStr of + Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') + browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] + return () + Right{} -> return () + +check :: Verbosity -> [FilePath] -> IO () +check verbosity paths = do + flip mapM_ paths $ \path -> do + notice verbosity $ "Checking " ++ path ++ "... " + handlePackage verbosity checkURI (return ()) path + +handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO () +handlePackage verbosity uri auth path = + do req <- mkRequest uri path + p <- proxy verbosity + debug verbosity $ "\n" ++ show req + (_,resp) <- browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + auth + setAuthorityGen (\_ _ -> return Nothing) + request req + debug verbosity $ show resp + case rspCode resp of + (2,0,0) -> do notice verbosity "OK" + (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " + ++ map intToDigit [x,y,z] ++ " " + ++ rspReason resp + case findHeader HdrContentType resp of + Just "text/plain" -> notice verbosity $ rspBody resp + _ -> debug verbosity $ rspBody resp + +mkRequest :: URI -> FilePath -> IO Request +mkRequest uri path = + do pkg <- readBinaryFile path + boundary <- genBoundary + let body = printMultiPart boundary (mkFormData path pkg) + return $ Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + +readBinaryFile :: FilePath -> IO String +readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents + +genBoundary :: IO String +genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" + +mkFormData :: FilePath -> String -> [BodyPart] +mkFormData path pkg = + -- yes, web browsers are that stupid (re quoting) + [BodyPart [Header hdrContentDisposition ("form-data; name=package; filename=\""++path++"\""), + Header HdrContentType "application/x-gzip"] + pkg] + +hdrContentDisposition :: HeaderName +hdrContentDisposition = HdrCustom "Content-disposition" + +-- * Multipart, partly stolen from the cgi package. + +data BodyPart = BodyPart [Header] String + +printMultiPart :: String -> [BodyPart] -> String +printMultiPart boundary xs = + concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf + +printBodyPart :: String -> BodyPart -> String +printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c + +crlf :: String +crlf = "\r\n" diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Utils.hs @@ -0,0 +1,59 @@ +module Distribution.Client.Utils where + +import Data.List + ( sortBy, groupBy ) +import qualified Data.ByteString.Lazy as BS +import System.FilePath + ( (<.>), splitFileName ) +import System.IO + ( openBinaryTempFile, hClose ) +import System.Directory + ( removeFile, renameFile ) +import qualified Control.Exception as Exception + ( handle, throwIO ) + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +-- * The result list never contains @(Nothing, Nothing)@. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq a b = case cmp a b of + EQ -> True + _ -> False + moreThanOne (_:_:_) = True + moreThanOne _ = False + +writeFileAtomic :: FilePath -> BS.ByteString -> IO () +writeFileAtomic targetFile content = do + (tmpFile, tmpHandle) <- openBinaryTempFile targetDir template + Exception.handle (\err -> do hClose tmpHandle + removeFile tmpFile + Exception.throwIO err) $ do + BS.hPut tmpHandle content + hClose tmpHandle + renameFile tmpFile targetFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,225 @@ +{-# OPTIONS -cpp -fffi #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -cpp -fffi #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find it's own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own pid and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import qualified System.Win32 as Win32 +import qualified System.Win32.DLL as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (Verbosity, showForCabal) +import Distribution.Simple.Utils (debug, info) + +import Prelude hiding (log) + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the pid and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- mapM canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the pid might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + + log $ "waiting for the child to start up" + waitForSingleObject event (10*1000) -- wait at most 10 sec + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamted itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +foreign import stdcall unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import stdcall unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import stdcall unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import stdcall unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import stdcall unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die) + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" + +#endif diff --git a/Hackage/Check.hs b/Hackage/Check.hs deleted file mode 100644 --- a/Hackage/Check.hs +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Check --- Copyright : (c) Lennart Kolmodin 2008 --- License : BSD-like --- --- Maintainer : kolmodin@haskell.org --- Stability : provisional --- Portability : portable --- --- Check a package for common mistakes --- ------------------------------------------------------------------------------ -module Hackage.Check ( - check - ) where - -import Control.Monad ( when, unless ) - -import Distribution.PackageDescription ( readPackageDescription ) -import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.Verbosity ( Verbosity ) -import Distribution.Simple.Utils ( defaultPackageDesc, toUTF8 ) - -check :: Verbosity -> IO Bool -check verbosity = do - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- Hovever, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. - let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) - buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] - buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] - distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] - - unless (null buildImpossible) $ do - putStrLn "The package will not build sanely due to these errors:" - mapM_ (putStrLn . toUTF8. explanation) buildImpossible - putStrLn "" - - unless (null buildWarning) $ do - putStrLn "The following warnings are likely affect your build negatively:" - mapM_ (putStrLn . toUTF8 . explanation) buildWarning - putStrLn "" - - unless (null distSuspicious) $ do - putStrLn "These warnings may cause trouble when distributing the package:" - mapM_ (putStrLn . toUTF8 . explanation) distSuspicious - putStrLn "" - - unless (null distInexusable) $ do - putStrLn "The following errors will cause portability problems on other environments:" - mapM_ (putStrLn . toUTF8 . explanation) distInexusable - putStrLn "" - - let isDistError (PackageDistSuspicious {}) = False - isDistError _ = True - errors = filter isDistError packageChecks - - unless (null errors) $ do - putStrLn "Hackage would reject this package." - - when (null packageChecks) $ do - putStrLn "No errors or warnings could be found in the package." - - return (null packageChecks) diff --git a/Hackage/Config.hs b/Hackage/Config.hs deleted file mode 100644 --- a/Hackage/Config.hs +++ /dev/null @@ -1,284 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Config --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Utilities for handling saved state such as known packages, known servers and downloaded packages. ------------------------------------------------------------------------------ -module Hackage.Config - ( SavedConfig(..) - , savedConfigToConfigFlags - , configRepos - , configPackageDB - , defaultConfigFile - , defaultCacheDir - , loadConfig - , showConfig - ) where - -import Prelude hiding (catch) -import Data.Char (isAlphaNum) -import Data.Maybe (fromMaybe) -import Control.Monad (when) -import Data.Monoid (Monoid(..)) -import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory) -import System.FilePath ((), takeDirectory) -import Network.URI (parseAbsoluteURI, uriToString) -import Text.PrettyPrint.HughesPJ (text) - -import Distribution.Compat.ReadP as ReadP - ( ReadP, char, munch1, pfail ) -import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor) -import Distribution.ParseUtils - ( FieldDescr(..), simpleField, listField, liftField, field - , parseFilePathQ, parseTokenQ, showPWarning, ParseResult(..) ) -import Distribution.Simple.Compiler (PackageDB(..)) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), PathTemplate, toPathTemplate, fromPathTemplate ) -import Distribution.Simple.Command (ShowOrParseArgs(..), viewAsFieldDescr) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, fromFlagOrDefault - , ConfigFlags, configureOptions ) -import qualified Distribution.Simple.Setup as ConfigFlags -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Verbosity (Verbosity, normal) -import Distribution.System - ( OS(Windows), buildOS ) - -import Hackage.Types - ( RemoteRepo(..), Repo(..), Username(..), Password(..) ) -import Hackage.ParseUtils -import Hackage.Utils (readFileIfExists) -import Distribution.Simple.Utils (notice, warn) - -configPackageDB :: Cabal.ConfigFlags -> PackageDB -configPackageDB config = - fromFlagOrDefault defaultDB (Cabal.configPackageDB config) - where - defaultDB = case Cabal.configUserInstall config of - NoFlag -> UserPackageDB - Flag True -> UserPackageDB - Flag False -> GlobalPackageDB - --- --- * Configuration saved in the config file --- - -data SavedConfig = SavedConfig { - configCacheDir :: Flag FilePath, - configRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers. - configUploadUsername :: Flag Username, - configUploadPassword :: Flag Password, - configUserInstallDirs :: InstallDirs (Flag PathTemplate), - configGlobalInstallDirs :: InstallDirs (Flag PathTemplate), - configFlags :: ConfigFlags - } - -configUserInstall :: SavedConfig -> Flag Bool -configUserInstall = ConfigFlags.configUserInstall . configFlags - -configRepos :: SavedConfig -> [Repo] -configRepos config = - [ let cacheDir = fromFlag (configCacheDir config) - remoteRepoName remote - in Repo remote cacheDir - | remote <- configRemoteRepos config ] - -savedConfigToConfigFlags :: Flag Bool -> SavedConfig -> Cabal.ConfigFlags -savedConfigToConfigFlags userInstallFlag config = (configFlags config) { - Cabal.configUserInstall = toFlag userInstall, - Cabal.configInstallDirs = if userInstall - then configUserInstallDirs config - else configGlobalInstallDirs config - } - where userInstall :: Bool - userInstall = fromFlag $ configUserInstall config - `mappend` userInstallFlag - --- --- * Default config --- - -defaultCabalDir :: IO FilePath -defaultCabalDir = getAppUserDataDirectory "cabal" - -defaultConfigFile :: IO FilePath -defaultConfigFile = do dir <- defaultCabalDir - return $ dir "config" - -defaultCacheDir :: IO FilePath -defaultCacheDir = do dir <- defaultCabalDir - return $ dir "packages" - -defaultCompiler :: CompilerFlavor -defaultCompiler = fromMaybe GHC defaultCompilerFlavor - -defaultUserInstall :: Bool -defaultUserInstall = case buildOS of - -- We do global installs by default on Windows - Windows -> False - -- and per-user installs by default everywhere else - _ -> True - -defaultUserInstallDirs :: IO (InstallDirs (Flag PathTemplate)) -defaultUserInstallDirs = - do userPrefix <- defaultCabalDir - return $ defaultGlobalInstallDirs { - prefix = toFlag (toPathTemplate userPrefix) - } - -defaultGlobalInstallDirs :: InstallDirs (Flag PathTemplate) -defaultGlobalInstallDirs = mempty - -defaultSavedConfig :: IO SavedConfig -defaultSavedConfig = - do userInstallDirs <- defaultUserInstallDirs - cacheDir <- defaultCacheDir - return SavedConfig { - configFlags = mempty { - ConfigFlags.configHcFlavor = toFlag defaultCompiler - , ConfigFlags.configVerbosity = toFlag normal - , ConfigFlags.configUserInstall = toFlag defaultUserInstall - , ConfigFlags.configInstallDirs = error - "ConfigFlags.installDirs: avoid this field. Use UserInstallDirs \ - \ or GlobalInstallDirs instead" - } - , configUserInstallDirs = userInstallDirs - , configGlobalInstallDirs = defaultGlobalInstallDirs - , configCacheDir = toFlag cacheDir - , configRemoteRepos = [defaultRemoteRepo] - , configUploadUsername = mempty - , configUploadPassword = mempty - } - -defaultRemoteRepo :: RemoteRepo -defaultRemoteRepo = RemoteRepo "hackage.haskell.org" uri - where - Just uri = parseAbsoluteURI "http://hackage.haskell.org/packages/archive" - --- --- * Config file reading --- - -loadConfig :: Verbosity -> FilePath -> IO SavedConfig -loadConfig verbosity configFile = - do defaultConf <- defaultSavedConfig - minp <- readFileIfExists configFile - case minp of - Nothing -> do notice verbosity $ "Config file " ++ configFile ++ " not found." - notice verbosity $ "Writing default configuration to " ++ configFile - writeDefaultConfigFile configFile defaultConf - return defaultConf - Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of - ParseOk ws conf -> - do when (not $ null ws) $ warn verbosity $ - unlines (map (showPWarning configFile) ws) - return conf - ParseFailed err -> - do warn verbosity $ "Error parsing config file " - ++ configFile ++ ": " ++ showPError err - warn verbosity $ "Using default configuration." - return defaultConf - where defaultConf' = defaultConf { configRemoteRepos = [] } - -writeDefaultConfigFile :: FilePath -> SavedConfig -> IO () -writeDefaultConfigFile file cfg = - do createDirectoryIfMissing True (takeDirectory file) - writeFile file $ showFields configWriteFieldDescrs cfg ++ "\n" - -showConfig :: SavedConfig -> String -showConfig = showFields configFieldDescrs - --- | All config file fields. -configFieldDescrs :: [FieldDescr SavedConfig] -configFieldDescrs = - map ( configFlagsField . viewAsFieldDescr) (configureOptions ShowArgs) - ++ configCabalInstallFieldDescrs - ++ map userInstallDirField installDirDescrs - ++ map globalInstallDirField installDirDescrs - -configCabalInstallFieldDescrs :: [FieldDescr SavedConfig] -configCabalInstallFieldDescrs = - [ listField "repos" - (text . showRepo) parseRepo - configRemoteRepos (\rs cfg -> cfg { configRemoteRepos = rs }) - , simpleField "cachedir" - (text . show . fromFlagOrDefault "") - (fmap emptyToNothing parseFilePathQ) - configCacheDir (\d cfg -> cfg { configCacheDir = d }) - , simpleField "hackage-username" - (text . show . fromFlagOrDefault "" . fmap unUsername) - (fmap (fmap Username . emptyToNothing) parseTokenQ) - configUploadUsername (\d cfg -> cfg { configUploadUsername = d }) - , simpleField "hackage-password" - (text . show . fromFlagOrDefault "" . fmap unPassword) - (fmap (fmap Password . emptyToNothing) parseTokenQ) - configUploadPassword (\d cfg -> cfg { configUploadPassword = d }) - ] - where emptyToNothing "" = mempty - emptyToNothing f = toFlag f - --- | The subset of the config file fields that we write out --- if the config file is missing. -configWriteFieldDescrs :: [FieldDescr SavedConfig] -configWriteFieldDescrs = configCabalInstallFieldDescrs - ++ [f | f <- configFieldDescrs, fieldName f `elem` ["compiler", "user-install"]] - -installDirDescrs :: [FieldDescr (InstallDirs (Flag PathTemplate))] -installDirDescrs = - [ installDirField "prefix" prefix (\d ds -> ds { prefix = d }) - , installDirField "bindir" bindir (\d ds -> ds { bindir = d }) - , installDirField "libdir" libdir (\d ds -> ds { libdir = d }) - , installDirField "libexecdir" libexecdir (\d ds -> ds { libexecdir = d }) - , installDirField "datadir" datadir (\d ds -> ds { datadir = d }) - , installDirField "docdir" docdir (\d ds -> ds { docdir = d }) - , installDirField "htmldir" htmldir (\d ds -> ds { htmldir = d }) - ] - -configFlagsField :: FieldDescr ConfigFlags -> FieldDescr SavedConfig -configFlagsField = liftField configFlags (\ff cfg -> cfg{configFlags=ff}) - - -userInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig -userInstallDirField f = modifyFieldName ("user-"++) $ - liftField configUserInstallDirs - (\d cfg -> cfg { configUserInstallDirs = d }) - f - -globalInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig -globalInstallDirField f = modifyFieldName ("global-"++) $ - liftField configGlobalInstallDirs - (\d cfg -> cfg { configGlobalInstallDirs = d }) - f - -installDirField :: String - -> (InstallDirs (Flag PathTemplate) -> Flag PathTemplate) - -> (Flag PathTemplate -> InstallDirs (Flag PathTemplate) -> InstallDirs (Flag PathTemplate)) - -> FieldDescr (InstallDirs (Flag PathTemplate)) -installDirField name get set = - liftField get set $ - field name (text . fromPathTemplate . fromFlag) - (fmap (toFlag . toPathTemplate) parseFilePathQ) - -modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a -modifyFieldName f d = d { fieldName = f (fieldName d) } - -showRepo :: RemoteRepo -> String -showRepo repo = remoteRepoName repo ++ ":" - ++ uriToString id (remoteRepoURI repo) [] - -parseRepo :: ReadP r RemoteRepo -parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.") - char ':' - uriStr <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?") - uri <- maybe ReadP.pfail return (parseAbsoluteURI uriStr) - return $ RemoteRepo { - remoteRepoName = name, - remoteRepoURI = uri - } - diff --git a/Hackage/Dependency.hs b/Hackage/Dependency.hs deleted file mode 100644 --- a/Hackage/Dependency.hs +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007 --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Top level interface to dependency resolution. ------------------------------------------------------------------------------ -module Hackage.Dependency ( - resolveDependencies, - resolveDependenciesWithProgress, - PackagesVersionPreference(..), - upgradableDependencies, - ) where - ---import Hackage.Dependency.Naive (naiveResolver) -import Hackage.Dependency.Bogus (bogusResolver) -import Hackage.Dependency.TopDown (topDownResolver) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.InstallPlan (InstallPlan) -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) ) -import Hackage.Dependency.Types - ( PackageName, DependencyResolver, PackageVersionPreference(..) - , Progress(..), foldProgress ) -import Distribution.Package - ( PackageIdentifier(..), packageVersion, packageName - , Dependency(..), Package(..), PackageFixedDeps(..) ) -import Distribution.Version - ( VersionRange(LaterVersion) ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( OS, Arch ) -import Distribution.Simple.Utils (comparing) -import Hackage.Utils (mergeBy, MergeResult(..)) - -import Data.List (maximumBy) -import Data.Monoid (Monoid(mempty)) -import qualified Data.Set as Set -import Data.Set (Set) -import Control.Exception (assert) - -defaultResolver :: DependencyResolver a -defaultResolver = topDownResolver ---for the brave: try the new topDownResolver, but only with --dry-run !!! - --- | Global policy for the versions of all packages. --- -data PackagesVersionPreference = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest available version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - -resolveDependencies :: OS - -> Arch - -> CompilerId - -> Maybe (PackageIndex InstalledPackageInfo) - -> PackageIndex AvailablePackage - -> PackagesVersionPreference - -> [UnresolvedDependency] - -> Either String (InstallPlan a) -resolveDependencies os arch comp installed available pref deps = - foldProgress (flip const) Left Right $ - resolveDependenciesWithProgress os arch comp installed available pref deps - -resolveDependenciesWithProgress :: OS - -> Arch - -> CompilerId - -> Maybe (PackageIndex InstalledPackageInfo) - -> PackageIndex AvailablePackage - -> PackagesVersionPreference - -> [UnresolvedDependency] - -> Progress String String (InstallPlan a) -resolveDependenciesWithProgress os arch comp (Just installed) = - dependencyResolver defaultResolver os arch comp installed - -resolveDependenciesWithProgress os arch comp Nothing = - dependencyResolver bogusResolver os arch comp mempty - -hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p -hideBrokenPackages index = - check (null . PackageIndex.brokenPackages) - . foldr (PackageIndex.deletePackageId . packageId) index - . PackageIndex.reverseDependencyClosure index - . map (packageId . fst) - $ PackageIndex.brokenPackages index - where - check p x = assert (p x) x - -hideBasePackage :: Package p => PackageIndex p -> PackageIndex p -hideBasePackage = PackageIndex.deletePackageName "base" - . PackageIndex.deletePackageName "ghc-prim" - -dependencyResolver - :: DependencyResolver a - -> OS -> Arch -> CompilerId - -> PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> PackagesVersionPreference - -> [UnresolvedDependency] - -> Progress String String (InstallPlan a) -dependencyResolver resolver os arch comp installed available pref deps = - let installed' = hideBrokenPackages installed - available' = hideBasePackage available - in fmap toPlan - $ resolver os arch comp installed' available' preference deps - - where - toPlan pkgs = - case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of - Right plan -> plan - Left problems -> error $ unlines $ - "internal error: could not construct a valid install plan." - : "The proposed (invalid) plan contained the following problems:" - : map InstallPlan.showPlanProblem problems - - preference = interpretPackagesVersionPreference initialPkgNames pref - initialPkgNames = Set.fromList - [ name | UnresolvedDependency (Dependency name _) _ <- deps ] - --- | Give an interpretation to the global 'PackagesVersionPreference' as --- specific per-package 'PackageVersionPreference'. --- -interpretPackagesVersionPreference :: Set PackageName - -> PackagesVersionPreference - -> (PackageName -> PackageVersionPreference) -interpretPackagesVersionPreference selected pref = case pref of - PreferAllLatest -> const PreferLatest - PreferAllInstalled -> const PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else: - if pkgname `Set.member` selected - then PreferLatest - else PreferInstalled - --- | Given the list of installed packages and available packages, figure --- out which packages can be upgraded. --- -upgradableDependencies :: PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> [Dependency] -upgradableDependencies installed available = - [ Dependency name (LaterVersion latestVersion) - -- This is really quick (linear time). The trick is that we're doing a - -- merge join of two tables. We can do it as a merge because they're in - -- a comparable order because we're getting them from the package indexs. - | InBoth latestInstalled allAvailable - <- mergeBy (\a (b:_) -> packageName a `compare` packageName b) - [ maximumBy (comparing packageVersion) pkgs - | pkgs <- PackageIndex.allPackagesByName installed ] - (PackageIndex.allPackagesByName available) - , let (PackageIdentifier name latestVersion) = packageId latestInstalled - , any (\p -> packageVersion p > latestVersion) allAvailable ] diff --git a/Hackage/Dependency/Bogus.hs b/Hackage/Dependency/Bogus.hs deleted file mode 100644 --- a/Hackage/Dependency/Bogus.hs +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency.Bogus --- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007 --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- A dependency resolver for when we do not know what packages are installed. ------------------------------------------------------------------------------ -module Hackage.Dependency.Bogus ( - bogusResolver - ) where - -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , ConfiguredPackage(..) ) -import Hackage.Dependency.Types - ( DependencyResolver, Progress(..) ) -import qualified Hackage.InstallPlan as InstallPlan - -import Distribution.Package - ( PackageIdentifier(..), Dependency(..), Package(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.Version - ( VersionRange(IntersectVersionRanges) ) -import Distribution.Simple.Utils - ( equating, comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( maximumBy, sortBy, groupBy ) - --- | This resolver thinks that every package is already installed. --- --- We need this for hugs and nhc98 which do not track installed packages. --- We just pretend that everything is installed and hope for the best. --- -bogusResolver :: DependencyResolver a -bogusResolver os arch comp _ available _ = resolveFromAvailable [] - . combineDependencies - where - resolveFromAvailable chosen [] = Done chosen - resolveFromAvailable chosen (UnresolvedDependency dep flags : deps) = - case latestAvailableSatisfying available dep of - Nothing -> Fail ("Unresolved dependency: " ++ display dep) - Just apkg@(AvailablePackage _ pkg _) -> - case finalizePackageDescription flags none os arch comp [] pkg of - Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps) - where - msg = "selecting " ++ display (packageId pkg) - cpkg = fudgeChosenPackage apkg flags' - chosen' = InstallPlan.Configured cpkg : chosen - _ -> error "bogusResolver: impossible happened" - where - none :: Maybe (PackageIndex PackageIdentifier) - none = Nothing - -fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage -fudgeChosenPackage (AvailablePackage pkgid pkg source) flags = - ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source) - flags ([] :: [PackageIdentifier]) -- empty list of deps - where - -- | Pretend that a package has no dependencies. Go through the - -- 'GenericPackageDescription' and strip them all out. - -- - stripDependencies :: GenericPackageDescription -> GenericPackageDescription - stripDependencies gpkg = gpkg { - condLibrary = fmap stripDeps (condLibrary gpkg), - condExecutables = [ (name, stripDeps tree) - | (name, tree) <- condExecutables gpkg ] - } - stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a - stripDeps = mapTreeConstrs (const []) - - mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a - mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs) - where - g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me) - -combineDependencies :: [UnresolvedDependency] -> [UnresolvedDependency] -combineDependencies = map combineGroup - . groupBy (equating depName) - . sortBy (comparing depName) - where - combineGroup deps = UnresolvedDependency (Dependency name ver) flags - where name = depName (head deps) - ver = foldr1 IntersectVersionRanges . map depVer $ deps - flags = concatMap depFlags deps - depName (UnresolvedDependency (Dependency name _) _) = name - depVer (UnresolvedDependency (Dependency _ ver) _) = ver - --- | Gets the latest available package satisfying a dependency. -latestAvailableSatisfying :: PackageIndex AvailablePackage - -> Dependency - -> Maybe AvailablePackage -latestAvailableSatisfying index dep = - case PackageIndex.lookupDependency index dep of - [] -> Nothing - pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs) diff --git a/Hackage/Dependency/Naive.hs b/Hackage/Dependency/Naive.hs deleted file mode 100644 --- a/Hackage/Dependency/Naive.hs +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency --- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007, --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- A dependency resolver that is not very sophisticated. --- It often makes installation plans with inconsistent dependencies. ------------------------------------------------------------------------------ -module Hackage.Dependency.Naive ( - naiveResolver - ) where - -import Distribution.InstalledPackageInfo (InstalledPackageInfo_(package)) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , ConfiguredPackage(..) ) -import Hackage.Dependency.Types - ( DependencyResolver, Progress(..) ) -import Distribution.Package - ( PackageIdentifier(..), Dependency(..), Package(..) ) -import Distribution.PackageDescription - ( PackageDescription(buildDepends), GenericPackageDescription - , FlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( OS, Arch ) -import Distribution.Simple.Utils (comparing, intercalate) -import Hackage.Utils - ( showDependencies ) -import Distribution.Text - ( display ) - -import Control.Monad (mplus) -import Data.List (maximumBy) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(mappend)) - -naiveResolver :: DependencyResolver a -naiveResolver os arch comp installed available _ deps = - packagesToInstall installed - [ resolveDependency os arch comp installed available dep flags - | UnresolvedDependency dep flags <- deps] - -resolveDependency :: OS - -> Arch - -> CompilerId - -> PackageIndex InstalledPackageInfo -- ^ Installed packages. - -> PackageIndex AvailablePackage -- ^ Installable packages - -> Dependency - -> FlagAssignment - -> ResolvedDependency -resolveDependency os arch comp installed available dep flags - = fromMaybe (UnavailableDependency dep) $ resolveFromInstalled `mplus` resolveFromAvailable - where - resolveFromInstalled = fmap (InstalledDependency dep) $ latestInstalledSatisfying installed dep - resolveFromAvailable = - do pkg <- latestAvailableSatisfying available dep - (deps, flags') <- getDependencies os arch comp installed available - (packageDescription pkg) flags - return $ AvailableDependency dep pkg flags' - [ resolveDependency os arch comp installed available dep' [] - | dep' <- deps ] - --- | Gets the latest installed package satisfying a dependency. -latestInstalledSatisfying :: PackageIndex InstalledPackageInfo -> Dependency -> Maybe PackageIdentifier -latestInstalledSatisfying index dep = - case PackageIndex.lookupDependency index dep of - [] -> Nothing - pkgs -> Just (maximumBy (comparing pkgVersion) (map package pkgs)) - --- | Gets the latest available package satisfying a dependency. -latestAvailableSatisfying :: PackageIndex AvailablePackage - -> Dependency - -> Maybe AvailablePackage -latestAvailableSatisfying index dep = - case PackageIndex.lookupDependency index dep of - [] -> Nothing - pkgs -> Just (maximumBy (comparing (pkgVersion . packageId)) pkgs) - --- | Gets the dependencies of an available package. -getDependencies :: OS - -> Arch - -> CompilerId - -> PackageIndex InstalledPackageInfo -- ^ Installed packages. - -> PackageIndex AvailablePackage -- ^ Available packages - -> GenericPackageDescription - -> FlagAssignment - -> Maybe ([Dependency], FlagAssignment) - -- ^ If successful, this is the list of dependencies. - -- If flag assignment failed, this is the list of - -- missing dependencies. -getDependencies os arch comp installed available pkg flags - = case e of - Left _missing -> Nothing - Right (desc,flags') -> Just (buildDepends desc, flags') - where - e = finalizePackageDescription - flags - (let --TODO: find a better way to do this: - flatten :: Package pkg => PackageIndex pkg - -> PackageIndex PackageIdentifier - flatten = PackageIndex.fromList . map packageId - . PackageIndex.allPackages - in Just (flatten available `mappend` flatten installed)) - os arch comp [] pkg - -packagesToInstall :: PackageIndex InstalledPackageInfo - -> [ResolvedDependency] - -> Progress String String [InstallPlan.PlanPackage a] - -- ^ Either a list of missing dependencies, or a graph - -- of packages to install, with their options. -packagesToInstall allInstalled deps0 = - case unzipEithers (map getAvailable deps0) of - ([], ok) -> - let selectedAvailable :: [InstallPlan.ConfiguredPackage] - selectedAvailable = concatMap snd ok - - selectedInstalled :: [InstalledPackageInfo] - selectedInstalled = - either PackageIndex.allPackages - (\borked -> error $ unlines - [ "Package " ++ display (packageId pkg) - ++ " depends on the following packages which are missing from the plan " - ++ intercalate ", " (map display missingDeps) - | (pkg, missingDeps) <- borked ]) - $ PackageIndex.dependencyClosure - allInstalled - (getInstalled deps0) - - in Done $ map InstallPlan.Configured selectedAvailable - ++ map InstallPlan.PreExisting selectedInstalled - - (missing, _) -> Fail $ "Unresolved dependencies: " - ++ showDependencies (concat missing) - - where - getAvailable :: ResolvedDependency - -> Either [Dependency] - (PackageIdentifier, [InstallPlan.ConfiguredPackage]) - getAvailable (InstalledDependency _ pkgid ) - = Right (pkgid, []) - getAvailable (AvailableDependency _ pkg flags deps) = - case unzipEithers (map getAvailable deps) of - ([], ok) -> let resolved = InstallPlan.ConfiguredPackage pkg flags - [ pkgid | (pkgid, _) <- ok ] - : concatMap snd ok - in Right (packageId pkg, resolved) - (missing, _) -> Left (concat missing) - getAvailable (UnavailableDependency dep) = Left [dep] - - getInstalled :: [ResolvedDependency] -> [PackageIdentifier] - getInstalled [] = [] - getInstalled (dep:deps) = case dep of - InstalledDependency _ pkgid -> pkgid : getInstalled deps - AvailableDependency _ _ _ deps' -> getInstalled (deps'++deps) - UnavailableDependency _ -> getInstalled deps - --- TODO: kill this data type -data ResolvedDependency - = InstalledDependency Dependency PackageIdentifier - | AvailableDependency Dependency AvailablePackage FlagAssignment [ResolvedDependency] - | UnavailableDependency Dependency - deriving (Show) - -unzipEithers :: [Either a b] -> ([a], [b]) -unzipEithers = foldr (flip consEither) ([], []) - where consEither ~(ls,rs) = either (\l -> (l:ls,rs)) (\r -> (ls,r:rs)) diff --git a/Hackage/Dependency/TopDown.hs b/Hackage/Dependency/TopDown.hs deleted file mode 100644 --- a/Hackage/Dependency/TopDown.hs +++ /dev/null @@ -1,598 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ -module Hackage.Dependency.TopDown ( - topDownResolver - ) where - -import Hackage.Dependency.TopDown.Types -import qualified Hackage.Dependency.TopDown.Constraints as Constraints -import Hackage.Dependency.TopDown.Constraints - ( Satisfiable(..) ) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.InstallPlan - ( PlanPackage(..) ) -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , ConfiguredPackage(..) ) -import Hackage.Dependency.Types - ( PackageName, DependencyResolver, PackageVersionPreference(..) - , Progress(..), foldProgress ) - -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Package - ( PackageIdentifier, Package(packageId), packageVersion, packageName - , Dependency(Dependency), thisPackageVersion, notThisPackageVersion - , PackageFixedDeps(depends) ) -import Distribution.PackageDescription - ( PackageDescription(buildDepends) ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, flattenPackageDescription ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( OS, Arch ) -import Distribution.Simple.Utils - ( equating, comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( foldl', maximumBy, minimumBy, deleteBy, nub, sort ) -import Data.Maybe - ( fromJust, fromMaybe ) -import Data.Monoid - ( Monoid(mempty) ) -import Control.Monad - ( guard ) -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Graph as Graph -import qualified Data.Array as Array - --- ------------------------------------------------------------ --- * Search state types --- ------------------------------------------------------------ - -type Constraints = Constraints.Constraints - InstalledPackage UnconfiguredPackage ExclusionReason -type SelectedPackages = PackageIndex SelectedPackage - --- ------------------------------------------------------------ --- * The search tree type --- ------------------------------------------------------------ - -data SearchSpace inherited pkg - = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] - | Failure Failure - --- ------------------------------------------------------------ --- * Traverse a search tree --- ------------------------------------------------------------ - -explore :: (PackageName -> PackageVersionPreference) - -> SearchSpace a SelectablePackage - -> Progress Log Failure a - -explore _ (Failure failure) = Fail failure -explore _explore (ChoiceNode result []) = Done result -explore pref (ChoiceNode _ choices) = - case [ choice | [choice] <- choices ] of - ((pkg, node'):_) -> Step (Select pkg []) (explore pref node') - [] -> seq pkgs' -- avoid retaining defaultChoice - $ Step (Select pkg pkgs') (explore pref node') - where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (pkg, node') = maximumBy (bestByPref pkgname) choice - pkgs' = deleteBy (equating packageId) pkg (map fst choice) - - where - topSortNumber choice = case fst (head choice) of - InstalledOnly (InstalledPackage _ i _) -> i - AvailableOnly (UnconfiguredPackage _ i _) -> i - InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i - - bestByPref pkgname = case pref pkgname of - PreferLatest -> comparing (\(p,_) -> packageId p) - PreferInstalled -> comparing (\(p,_) -> (isInstalled p, packageId p)) - where isInstalled (AvailableOnly _) = False - isInstalled _ = True - --- ------------------------------------------------------------ --- * Generate a search tree --- ------------------------------------------------------------ - -type ConfigurePackage = PackageIndex SelectablePackage - -> SelectablePackage - -> Either [Dependency] SelectedPackage - -searchSpace :: ConfigurePackage - -> Constraints - -> SelectedPackages - -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints) SelectablePackage -searchSpace configure constraints selected next = - ChoiceNode (selected, constraints) - [ [ (pkg, select name pkg) - | pkg <- PackageIndex.lookupPackageName available name ] - | name <- Set.elems next ] - where - available = Constraints.choices constraints - - select name pkg = case configure available pkg of - Left missing -> Failure $ ConfigureFailed pkg - [ (dep, Constraints.conflicting constraints dep) - | dep <- missing ] - Right pkg' -> - let selected' = PackageIndex.insert pkg' selected - newPkgs = [ name' - | dep <- packageConstraints pkg' - , let (Dependency name' _) = untagDependency dep - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = packageConstraints pkg' - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - in case constrainDeps pkg' newDeps constraints of - Left failure -> Failure failure - Right constraints' -> searchSpace configure - constraints' selected' next' - -packageConstraints :: SelectedPackage -> [TaggedDependency] -packageConstraints = either installedConstraints availableConstraints - . preferAvailable - where - preferAvailable (InstalledOnly pkg) = Left pkg - preferAvailable (AvailableOnly pkg) = Right pkg - preferAvailable (InstalledAndAvailable _ pkg) = Right pkg - installedConstraints (InstalledPackage _ _ deps) = - [ TaggedDependency InstalledConstraint (thisPackageVersion dep) - | dep <- deps ] - availableConstraints (SemiConfiguredPackage _ _ deps) = - [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] - -constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints - -> Either Failure Constraints -constrainDeps pkg [] cs = - case addPackageSelectConstraint (packageId pkg) cs of - Satisfiable cs' -> Right cs' - _ -> impossible -constrainDeps pkg (dep:deps) cs = - case addPackageDependencyConstraint (packageId pkg) dep cs of - Satisfiable cs' -> constrainDeps pkg deps cs' - Unsatisfiable -> impossible - ConflictsWith conflicts -> - Left (DependencyConflict pkg dep conflicts) - --- ------------------------------------------------------------ --- * The main algorithm --- ------------------------------------------------------------ - -search :: ConfigurePackage - -> (PackageName -> PackageVersionPreference) - -> Constraints - -> Set PackageName - -> Progress Log Failure (SelectedPackages, Constraints) -search configure pref constraints = - explore pref . searchSpace configure constraints mempty - --- ------------------------------------------------------------ --- * The top level resolver --- ------------------------------------------------------------ - --- | The main exported resolver, with string logging and failure types to fit --- the standard 'DependencyResolver' interface. --- -topDownResolver :: DependencyResolver a -topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' - where - mapMessages :: Progress Log Failure a -> Progress String String a - mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done - --- | The native resolver with detailed structured logging and failure types. --- -topDownResolver' :: OS -> Arch -> CompilerId - -> PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> (PackageName -> PackageVersionPreference) - -> [UnresolvedDependency] - -> Progress Log Failure [PlanPackage a] -topDownResolver' os arch comp installed available pref deps = - fmap (uncurry finalise) - . (\cs -> search configure pref cs initialPkgNames) - =<< constrainTopLevelDeps deps constraints - - where - configure = configurePackage os arch comp - constraints = Constraints.empty - (annotateInstalledPackages topSortNumber installed') - (annotateAvailablePackages deps topSortNumber available') - (installed', available') = selectNeededSubset installed available - initialPkgNames - topSortNumber = topologicalSortNumbering installed' available' - - initialDeps = [ dep | UnresolvedDependency dep _ <- deps ] - initialPkgNames = Set.fromList [ name | Dependency name _ <- initialDeps ] - - finalise selected = PackageIndex.allPackages - . improvePlan installed' - . PackageIndex.fromList - . finaliseSelectedPackages selected - -constrainTopLevelDeps :: [UnresolvedDependency] -> Constraints - -> Progress a Failure Constraints -constrainTopLevelDeps [] cs = Done cs -constrainTopLevelDeps (UnresolvedDependency dep _:deps) cs = - case addTopLevelDependencyConstraint dep cs of - Satisfiable cs' -> constrainTopLevelDeps deps cs' - Unsatisfiable -> Fail (TopLevelDependencyUnsatisfiable dep) - ConflictsWith conflicts -> Fail (TopLevelDependencyConflict dep conflicts) - -configurePackage :: OS -> Arch -> CompilerId -> ConfigurePackage -configurePackage os arch comp available spkg = case spkg of - InstalledOnly ipkg -> Right (InstalledOnly ipkg) - AvailableOnly apkg -> fmap AvailableOnly (configure apkg) - InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg) - (configure apkg) - where - configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = - case finalizePackageDescription flags (Just available) os arch comp [] p of - Left missing -> Left missing - Right (pkg, flags') -> Right $ - SemiConfiguredPackage apkg flags' (buildDepends pkg) - --- | Annotate each installed packages with its set of transative dependencies --- and its topological sort number. --- -annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) - -> PackageIndex InstalledPackageInfo - -> PackageIndex InstalledPackage -annotateInstalledPackages dfsNumber installed = PackageIndex.fromList - [ InstalledPackage pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) - | pkg <- PackageIndex.allPackages installed ] - where - transitiveDepends :: InstalledPackageInfo -> [PackageIdentifier] - transitiveDepends = map toPkgid . tail . Graph.reachable graph - . fromJust . toVertex . packageId - (graph, toPkgid, toVertex) = PackageIndex.dependencyGraph installed - - --- | Annotate each available packages with its topological sort number and any --- user-supplied partial flag assignment. --- -annotateAvailablePackages :: [UnresolvedDependency] - -> (PackageName -> TopologicalSortNumber) - -> PackageIndex AvailablePackage - -> PackageIndex UnconfiguredPackage -annotateAvailablePackages deps dfsNumber available = PackageIndex.fromList - [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) - | pkg <- PackageIndex.allPackages available - , let name = packageName pkg ] - where - flagsFor = fromMaybe [] . flip Map.lookup flagsMap - flagsMap = Map.fromList - [ (name, flags) - | UnresolvedDependency (Dependency name _) flags <- deps ] - --- | One of the heuristics we use when guessing which path to take in the --- search space is an ordering on the choices we make. It's generally better --- to make decisions about packages higer in the dep graph first since they --- place constraints on packages lower in the dep graph. --- --- To pick them in that order we annotate each package with its topological --- sort number. So if package A depends on package B then package A will have --- a lower topological sort number than B and we'll make a choice about which --- version of A to pick before we make a choice about B (unless there is only --- one possible choice for B in which case we pick that immediately). --- --- To construct these topological sort numbers we combine and flatten the --- installed and available package sets. We consider only dependencies between --- named packages, not including versions and for not-yet-configured packages --- we look at all the possible dependencies, not just those under any single --- flag assignment. This means we can actually get impossible combinations of --- edges and even cycles, but that doesn't really matter here, it's only a --- heuristic. --- -topologicalSortNumbering :: PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> (PackageName -> TopologicalSortNumber) -topologicalSortNumbering installed available = - \pkgname -> let Just vertex = toVertex pkgname - in topologicalSortNumbers Array.! vertex - where - topologicalSortNumbers = Array.array (Array.bounds graph) - (zip (Graph.topSort graph) [0..]) - (graph, _, toVertex) = Graph.graphFromEdges $ - [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed - , let deps = [ packageName dep - | pkg' <- pkgs - , dep <- depends pkg' ] ] - ++ [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available - , let deps = [ depName - | AvailablePackage _ pkg' _ <- pkgs - , Dependency depName _ <- - buildDepends (flattenPackageDescription pkg') ] ] - --- | We don't need the entire index (which is rather large and costly if we --- force it by examining the whole thing). So trace out the maximul subset of --- each index that we could possibly ever need. Do this by flattening packages --- and looking at the names of all possible dependencies. --- -selectNeededSubset :: PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackageInfo - ,PackageIndex AvailablePackage) -selectNeededSubset installed available = select mempty mempty - where - select :: PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackageInfo - ,PackageIndex AvailablePackage) - select installed' available' remaining - | Set.null remaining = (installed', available') - | otherwise = select installed'' available'' remaining'' - where - (next, remaining') = Set.deleteFindMin remaining - moreInstalled = PackageIndex.lookupPackageName installed next - moreAvailable = PackageIndex.lookupPackageName available next - moreRemaining = nub - $ [ packageName dep - | pkg <- moreInstalled - , dep <- depends pkg ] - ++ [ name - | AvailablePackage _ pkg _ <- moreAvailable - , Dependency name _ <- - buildDepends (flattenPackageDescription pkg) ] - installed'' = foldr PackageIndex.insert installed' moreInstalled - available'' = foldr PackageIndex.insert available' moreAvailable - remaining'' = foldr Set.insert remaining' moreRemaining - --- ------------------------------------------------------------ --- * Post processing the solution --- ------------------------------------------------------------ - -finaliseSelectedPackages :: SelectedPackages - -> Constraints - -> [PlanPackage a] -finaliseSelectedPackages selected constraints = - map finaliseSelected (PackageIndex.allPackages selected) - where - remainingChoices = Constraints.choices constraints - finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg - finaliseSelected (AvailableOnly apkg) = finaliseAvailable apkg - finaliseSelected (InstalledAndAvailable ipkg apkg) = - case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of - Nothing -> impossible --picked package not in constraints - Just (AvailableOnly _) -> impossible --to constrain to avail only - Just (InstalledOnly _) -> finaliseInstalled ipkg - Just (InstalledAndAvailable _ _) -> finaliseAvailable apkg - - finaliseInstalled (InstalledPackage pkg _ _) = InstallPlan.PreExisting pkg - finaliseAvailable (SemiConfiguredPackage pkg flags deps) = - InstallPlan.Configured (ConfiguredPackage pkg flags deps') - where deps' = [ packageId pkg' - | dep <- deps - , let pkg' = case PackageIndex.lookupDependency selected dep of - [pkg''] -> pkg'' - _ -> impossible ] - --- | Improve an existing installation plan by, where possible, swapping --- packages we plan to install with ones that are already installed. --- -improvePlan :: PackageIndex InstalledPackageInfo - -> PackageIndex (PlanPackage a) - -> PackageIndex (PlanPackage a) -improvePlan installed selected = foldl' improve selected - $ reverseTopologicalOrder selected - where - improve selected' = maybe selected' (flip PackageIndex.insert selected') - . improvePkg selected' - - -- The idea is to improve the plan by swapping a configured package for - -- an equivalent installed one. For a particular package the condition is - -- that the package be in a configured state, that a the same version be - -- already installed with the exact same dependencies and all the packages - -- in the plan that it depends on are in the installed state - improvePkg selected' pkgid = do - Configured pkg <- PackageIndex.lookupPackageId selected' pkgid - ipkg <- PackageIndex.lookupPackageId installed pkgid - guard $ sort (depends pkg) == nub (sort (depends ipkg)) - guard $ all (isInstalled selected') (depends pkg) - return (PreExisting ipkg) - - isInstalled selected' pkgid = - case PackageIndex.lookupPackageId selected' pkgid of - Just (PreExisting _) -> True - _ -> False - - reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg - -> [PackageIdentifier] - reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = PackageIndex.dependencyGraph index - --- ------------------------------------------------------------ --- * Adding and recording constraints --- ------------------------------------------------------------ - -addPackageSelectConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints ExclusionReason -addPackageSelectConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) - reason = SelectedOther pkgid - -addPackageExcludeConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints ExclusionReason -addPackageExcludeConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint - (notThisPackageVersion pkgid) - reason = ExcludedByConfigureFail - -addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints - -> Satisfiable Constraints ExclusionReason -addPackageDependencyConstraint pkgid dep constraints = - Constraints.constrain dep reason constraints - where - reason = ExcludedByPackageDependency pkgid dep - -addTopLevelDependencyConstraint :: Dependency -> Constraints - -> Satisfiable Constraints ExclusionReason -addTopLevelDependencyConstraint dep constraints = - Constraints.constrain taggedDep reason constraints - where - taggedDep = TaggedDependency NoInstalledConstraint dep - reason = ExcludedByTopLevelDependency dep - --- ------------------------------------------------------------ --- * Reasons for constraints --- ------------------------------------------------------------ - --- | For every constraint we record we also record the reason that constraint --- is needed. So if we end up failing due to conflicting constraints then we --- can give an explnanation as to what was conflicting and why. --- -data ExclusionReason = - - -- | We selected this other version of the package. That means we exclude - -- all the other versions. - SelectedOther PackageIdentifier - - -- | We excluded this version of the package because it failed to - -- configure probably because of unsatisfiable deps. - | ExcludedByConfigureFail - - -- | We excluded this version of the package because another package that - -- we selected imposed a dependency which this package did not satisfy. - | ExcludedByPackageDependency PackageIdentifier TaggedDependency - - -- | We excluded this version of the package because it did not satisfy - -- a dependency given as an original top level input. - -- - | ExcludedByTopLevelDependency Dependency - --- | Given an excluded package and the reason it was excluded, produce a human --- readable explanation. --- -showExclusionReason :: PackageIdentifier -> ExclusionReason -> String -showExclusionReason pkgid (SelectedOther pkgid') = - display pkgid ++ " was excluded because " ++ - display pkgid' ++ " was selected instead" -showExclusionReason pkgid ExcludedByConfigureFail = - display pkgid ++ " was excluded because it could not be configured" -showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = - display pkgid ++ " was excluded because " ++ - display pkgid' ++ " requires " ++ display (untagDependency dep) -showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = - display pkgid ++ " was excluded because of the top level dependency " ++ - display dep - - --- ------------------------------------------------------------ --- * Logging progress and failures --- ------------------------------------------------------------ - -data Log = Select SelectablePackage [SelectablePackage] -data Failure - = ConfigureFailed - SelectablePackage - [(Dependency, [(PackageIdentifier, [ExclusionReason])])] - | DependencyConflict - SelectedPackage TaggedDependency - [(PackageIdentifier, [ExclusionReason])] - | TopLevelDependencyConflict - Dependency - [(PackageIdentifier, [ExclusionReason])] - | TopLevelDependencyUnsatisfiable - Dependency - -showLog :: Log -> String -showLog (Select selected discarded) = - "selecting " ++ displayPkg selected ++ " " ++ kind selected - ++ case discarded of - [] -> "" - [d] -> " and discarding version " ++ display (packageVersion d) - _ -> " and discarding versions " - ++ listOf (display . packageVersion) discarded - where - kind (InstalledOnly _) = "(installed)" - kind (AvailableOnly _) = "(hackage)" - kind (InstalledAndAvailable _ _) = "(installed or hackage)" - -showFailure :: Failure -> String -showFailure (ConfigureFailed pkg missingDeps) = - "cannot configure " ++ displayPkg pkg ++ ". It requires " - ++ listOf (display . fst) missingDeps - ++ '\n' : unlines (map (uncurry whyNot) missingDeps) - - where - whyNot (Dependency name ver) [] = - "There is no available version of " ++ name - ++ " that satisfies " ++ display ver - - whyNot dep conflicts = - "For the dependency on " ++ display dep - ++ " there are these packages: " ++ listOf display pkgs - ++ ". However none of them are available.\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - - where pkgs = map fst conflicts - -showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = - "dependencies conflict: " - ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelDependencyConflict dep conflicts) = - "dependencies conflict: " - ++ "top level dependency " ++ display dep ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelDependencyUnsatisfiable (Dependency name ver)) = - "There is no available version of " ++ name - ++ " that satisfies " ++ display ver - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -impossible :: a -impossible = internalError "impossible" - -internalError :: String -> a -internalError msg = error $ "internal error: " ++ msg - -displayPkg :: Package pkg => pkg -> String -displayPkg = display . packageId - -listOf :: (a -> String) -> [a] -> String -listOf _ [] = [] -listOf disp [x0] = disp x0 -listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs - where go x [] = " and " ++ disp x - go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/Hackage/Dependency/TopDown/Constraints.hs b/Hackage/Dependency/TopDown/Constraints.hs deleted file mode 100644 --- a/Hackage/Dependency/TopDown/Constraints.hs +++ /dev/null @@ -1,244 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency.TopDown.Constraints --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- A set of satisfiable dependencies (package version constraints). ------------------------------------------------------------------------------ -module Hackage.Dependency.TopDown.Constraints ( - Constraints, - empty, - choices, - - constrain, - Satisfiable(..), - conflicting, - ) where - -import Hackage.Dependency.TopDown.Types -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.Package - ( PackageIdentifier, Package(packageId), packageVersion, packageName - , Dependency(Dependency) ) -import Distribution.Version - ( withinRange ) -import Distribution.Simple.Utils - ( comparing ) -import Hackage.Utils - ( mergeBy, MergeResult(..) ) - -import Data.List - ( foldl', sortBy ) -import Data.Monoid - ( Monoid(mempty) ) -import Control.Exception - ( assert ) - --- | A set of constraints on package versions. For each package name we record --- what other packages depends on it and what constraints they impose on the --- version of the package. --- -data (Package installed, Package available) - => Constraints installed available reason - = Constraints - - -- Remaining available choices - (PackageIndex (InstalledOrAvailable installed available)) - - -- Choices that we have excluded for some reason - -- usually by applying constraints - (PackageIndex (ExcludedPackage PackageIdentifier reason)) - -data ExcludedPackage pkg reason - = ExcludedPackage pkg [reason] -- reasons for excluding just the available - [reason] -- reasons for excluding installed and avail - -instance Package pkg => Package (ExcludedPackage pkg reason) where - packageId (ExcludedPackage p _ _) = packageId p - --- | The intersection between the two indexes is empty -invariant :: (Package installed, Package available) - => Constraints installed available a -> Bool -invariant (Constraints available excluded) = - all (uncurry ok) [ (a, e) | InBoth a e <- merged ] - where - merged = mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages excluded) - ok (InstalledOnly _) (ExcludedPackage _ _ []) = True - ok _ _ = False - --- | An update to the constraints can move packages between the two piles --- but not gain or loose packages. -transitionsTo :: (Package installed, Package available) - => Constraints installed available a - -> Constraints installed available a -> Bool -transitionsTo constraints @(Constraints available excluded ) - constraints'@(Constraints available' excluded') = - invariant constraints && invariant constraints' - && null availableGained && null excludedLost - && map packageId availableLost == map packageId excludedGained - - where - availableLost = foldr lost [] availableChange where - lost (OnlyInLeft pkg) rest = pkg : rest - lost (InBoth (InstalledAndAvailable _ pkg) - (InstalledOnly _)) rest = AvailableOnly pkg : rest - lost _ rest = rest - availableGained = [ pkg | OnlyInRight pkg <- availableChange ] - excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] - excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] - availableChange = mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder available) - (allPackagesInOrder available') - excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder excluded) - (allPackagesInOrder excluded') - ---FIXME: PackageIndex.allPackages returns in sorted order case-insensitively --- but that's no good for our merge which uses Ord -allPackagesInOrder :: Package pkg => PackageIndex pkg -> [pkg] -allPackagesInOrder index = - concatMap snd - . sortBy (comparing fst) - $ [ (packageName pkg, grp) - | grp@(pkg:_) <- PackageIndex.allPackagesByName index ] - --- | We construct 'Constraints' with an initial 'PackageIndex' of all the --- packages available. --- -empty :: (Package installed, Package available) - => PackageIndex installed - -> PackageIndex available - -> Constraints installed available reason -empty installed available = Constraints pkgs mempty - where - pkgs = PackageIndex.fromList - . map toInstalledOrAvailable - $ mergeBy (\a b -> packageId a `compare` packageId b) - (allPackagesInOrder installed) - (allPackagesInOrder available) - toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i - toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a - toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a - --- | The package choices that are still available. --- -choices :: (Package installed, Package available) - => Constraints installed available reason - -> PackageIndex (InstalledOrAvailable installed available) -choices (Constraints available _) = available - -data Satisfiable a reason - = Satisfiable a - | Unsatisfiable - | ConflictsWith [(PackageIdentifier, [reason])] - -constrain :: (Package installed, Package available) - => TaggedDependency - -> reason - -> Constraints installed available reason - -> Satisfiable (Constraints installed available reason) reason -constrain (TaggedDependency installedConstraint (Dependency name versionRange)) - reason constraints@(Constraints available excluded) - - | not anyRemaining - = if null conflicts then Unsatisfiable - else ConflictsWith conflicts - - | otherwise - = let constraints' = Constraints available' excluded' - in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' - - where - -- This tells us if any packages would remain at all for this package name if - -- we applied this constraint. This amounts to checking if any package - -- satisfies the given constraint, including version range and installation - -- status. - -- - anyRemaining = any satisfiesConstraint availableChoices - - conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll) - | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices - , satisfiesVersionConstraint pkg ] - - -- Applying this constraint may involve deleting some choices for this - -- package name, or restricting which install states are available. - available' = updateAvailable available - updateAvailable = flip (foldl' (flip update)) availableChoices where - update pkg | not (satisfiesVersionConstraint pkg) - = PackageIndex.deletePackageId (packageId pkg) - update _ | installedConstraint == NoInstalledConstraint - = id - update pkg = case pkg of - InstalledOnly _ -> id - AvailableOnly _ -> error "impossible" -- PackageIndex.deletePackageId (packageId pkg) - InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i) - - -- Applying the constraint means adding exclusions for the packages that - -- we're just freshly excluding, ie the ones we're removing from available. - excluded' = addNewExcluded . addOldExcluded $ excluded - addNewExcluded index = foldl' (flip exclude) index availableChoices where - exclude pkg - | not (satisfiesVersionConstraint pkg) - = PackageIndex.insert $ ExcludedPackage pkgid [] [reason] - | installedConstraint == NoInstalledConstraint - = id - | otherwise = case pkg of - InstalledOnly _ -> id - AvailableOnly _ -> PackageIndex.insert - (ExcludedPackage pkgid [reason] []) - InstalledAndAvailable _ _ -> - case PackageIndex.lookupPackageId excluded pkgid of - Just (ExcludedPackage _ avail both) -> - PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) - Nothing -> - PackageIndex.insert (ExcludedPackage pkgid [reason] []) - where pkgid = packageId pkg - - -- Additionally we have to add extra exclusions for any already-excluded - -- packages that happen to be covered by the (inverse of the) constraint. - addOldExcluded = flip (foldl' (flip exclude)) excludedChoices where - exclude (ExcludedPackage pkgid avail both) - -- if it doesn't satisfy the version constraint then we exclude the - -- package as a whole, the available or the installed instances or both. - | not (satisfiesVersionConstraint pkgid) - = PackageIndex.insert (ExcludedPackage pkgid avail (reason:both)) - -- if on the other hand it does satisfy the constraint and we were also - -- constraining to just the installed version then we exclude just the - -- available instance. - | installedConstraint == InstalledConstraint - = PackageIndex.insert (ExcludedPackage pkgid (reason:avail) both) - | otherwise = id - - -- util definitions - availableChoices = PackageIndex.lookupPackageName available name - excludedChoices = PackageIndex.lookupPackageName excluded name - - satisfiesConstraint pkg = satisfiesVersionConstraint pkg - && satisfiesInstallStateConstraint pkg - - satisfiesVersionConstraint pkg = - packageVersion pkg `withinRange` versionRange - - satisfiesInstallStateConstraint = case installedConstraint of - NoInstalledConstraint -> \_ -> True - InstalledConstraint -> \pkg -> case pkg of - AvailableOnly _ -> False - _ -> True - -conflicting :: (Package installed, Package available) - => Constraints installed available reason - -> Dependency - -> [(PackageIdentifier, [reason])] -conflicting (Constraints _ excluded) dep = - [ (pkgid, reasonsAvail ++ reasonsAll) --TODO - | ExcludedPackage pkgid reasonsAvail reasonsAll <- - PackageIndex.lookupDependency excluded dep ] diff --git a/Hackage/Dependency/TopDown/Types.hs b/Hackage/Dependency/TopDown/Types.hs deleted file mode 100644 --- a/Hackage/Dependency/TopDown/Types.hs +++ /dev/null @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency.TopDown.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Types for the top-down dependency resolver. ------------------------------------------------------------------------------ -module Hackage.Dependency.TopDown.Types where - -import Hackage.Types - ( AvailablePackage(..) ) - -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package - ( PackageIdentifier, Dependency, Package(packageId) ) -import Distribution.PackageDescription - ( FlagAssignment ) - --- ------------------------------------------------------------ --- * The various kinds of packages --- ------------------------------------------------------------ - -type SelectablePackage - = InstalledOrAvailable InstalledPackage UnconfiguredPackage - -type SelectedPackage - = InstalledOrAvailable InstalledPackage SemiConfiguredPackage - -data InstalledOrAvailable installed available - = InstalledOnly installed - | AvailableOnly available - | InstalledAndAvailable installed available - -type TopologicalSortNumber = Int - -data InstalledPackage - = InstalledPackage - InstalledPackageInfo - !TopologicalSortNumber - [PackageIdentifier] - -data UnconfiguredPackage - = UnconfiguredPackage - AvailablePackage - !TopologicalSortNumber - FlagAssignment - -data SemiConfiguredPackage - = SemiConfiguredPackage - AvailablePackage -- package info - FlagAssignment -- total flag assignment for the package - [Dependency] -- dependencies we end up with when we apply - -- the flag assignment - -instance Package InstalledPackage where - packageId (InstalledPackage p _ _) = packageId p - -instance Package UnconfiguredPackage where - packageId (UnconfiguredPackage p _ _) = packageId p - -instance Package SemiConfiguredPackage where - packageId (SemiConfiguredPackage p _ _) = packageId p - -instance (Package installed, Package available) - => Package (InstalledOrAvailable installed available) where - packageId (InstalledOnly p ) = packageId p - packageId (AvailableOnly p ) = packageId p - packageId (InstalledAndAvailable p _) = packageId p - --- ------------------------------------------------------------ --- * Tagged Dependency type --- ------------------------------------------------------------ - --- | Installed packages can only depend on other installed packages while --- packages that are not yet installed but which we plan to install can depend --- on installed or other not-yet-installed packages. --- --- This makes life more complex as we have to remember these constraints. --- -data TaggedDependency = TaggedDependency InstalledConstraint Dependency -data InstalledConstraint = InstalledConstraint | NoInstalledConstraint - deriving Eq - -untagDependency :: TaggedDependency -> Dependency -untagDependency (TaggedDependency _ dep) = dep diff --git a/Hackage/Dependency/Types.hs b/Hackage/Dependency/Types.hs deleted file mode 100644 --- a/Hackage/Dependency/Types.hs +++ /dev/null @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ -module Hackage.Dependency.Types ( - PackageName, - DependencyResolver, - PackageVersionPreference(..), - Progress(..), - foldProgress, - ) where - -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) ) -import qualified Hackage.InstallPlan as InstallPlan - -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Simple.PackageIndex - ( PackageIndex ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( OS, Arch ) - -import Prelude hiding (fail) - -type PackageName = String - --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. --- --- The reason for this interface is because there are dozens of approaches to --- solving the package dependency problem and we want to make it easy to swap --- in alternatives. --- -type DependencyResolver a = OS - -> Arch - -> CompilerId - -> PackageIndex InstalledPackageInfo - -> PackageIndex AvailablePackage - -> (PackageName -> PackageVersionPreference) - -> [UnresolvedDependency] - -> Progress String String [InstallPlan.PlanPackage a] - --- | A per-package preference on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackageVersionPreference = PreferInstalled | PreferLatest - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail. We may get intermediate steps before the final --- retult which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - --- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with --- two base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r - -instance Functor (Progress step fail) where - fmap f = foldProgress Step Fail (Done . f) - -instance Monad (Progress step fail) where - return a = Done a - p >>= f = foldProgress Step Fail f p diff --git a/Hackage/Fetch.hs b/Hackage/Fetch.hs deleted file mode 100644 --- a/Hackage/Fetch.hs +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Fetch --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Hackage.Fetch - ( - -- * Commands - fetch - , -- * Utilities - fetchPackage - , isFetched - , downloadIndex - ) where - -import Network.URI - ( URI(uriScheme, uriPath) ) -import Network.HTTP (ConnError(..), Response(..)) - -import Hackage.Types - ( UnresolvedDependency (..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), repoURI ) -import Hackage.Dependency - ( resolveDependencies, PackagesVersionPreference(..) ) -import Hackage.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies ) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.HttpUtils (getHTTP) - -import Distribution.Package - ( PackageIdentifier(..), Package(..) ) -import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDB ) -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.Simple.Configure (getInstalledPackages) -import Distribution.Simple.Utils - ( die, notice, debug, setupMessage, intercalate ) -import Distribution.System - ( buildOS, buildArch ) -import Distribution.Text - ( display ) -import Distribution.Verbosity (Verbosity) - -import Control.Exception (bracket) -import Control.Monad (filterM) -import System.Directory (doesFileExist, createDirectoryIfMissing) -import System.FilePath ((), (<.>)) -import System.Directory (copyFile) -import System.IO (IOMode(..), hPutStr, Handle, hClose, openBinaryFile) - - -downloadURI :: Verbosity - -> FilePath -- ^ Where to put it - -> URI -- ^ What to download - -> IO (Maybe ConnError) -downloadURI verbosity path uri - | uriScheme uri == "file:" = do - copyFile (uriPath uri) path - return Nothing - | otherwise = do - eitherResult <- getHTTP verbosity uri - case eitherResult of - Left err -> return (Just err) - Right rsp - | rspCode rsp == (2,0,0) -> withBinaryFile path WriteMode (`hPutStr` rspBody rsp) - >> return Nothing - | otherwise -> return (Just (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp)))) - --- Downloads a package to [config-dir/packages/package-id] and returns the path to the package. -downloadPackage :: Verbosity -> AvailablePackage -> IO String -downloadPackage verbosity pkg - = do let uri = packageURI pkg - dir = packageDir pkg - path = packageFile pkg - debug verbosity $ "GET " ++ show uri - createDirectoryIfMissing True dir - mbError <- downloadURI verbosity path uri - case mbError of - Just err -> die $ "Failed to download '" ++ display (packageId pkg) ++ "': " ++ show err - Nothing -> return path - --- Downloads an index file to [config-dir/packages/serv-id]. -downloadIndex :: Verbosity -> Repo -> IO FilePath -downloadIndex verbosity repo - = do let uri = (repoURI repo) { - uriPath = uriPath (repoURI repo) - ++ "/" ++ "00-index.tar.gz" - } - dir = repoCacheDir repo - path = dir "00-index" <.> "tar.gz" - createDirectoryIfMissing True dir - mbError <- downloadURI verbosity path uri - case mbError of - Just err -> die $ "Failed to download index '" ++ show err ++ "'" - Nothing -> return path - --- |Returns @True@ if the package has already been fetched. -isFetched :: AvailablePackage -> IO Bool -isFetched pkg = doesFileExist (packageFile pkg) - --- |Fetch a package if we don't have it already. -fetchPackage :: Verbosity -> AvailablePackage -> IO String -fetchPackage verbosity pkg - = do fetched <- isFetched pkg - if fetched - then do notice verbosity $ "'" ++ display (packageId pkg) ++ "' is cached." - return (packageFile pkg) - else do setupMessage verbosity "Downloading" (packageId pkg) - downloadPackage verbosity pkg - --- |Fetch a list of packages and their dependencies. -fetch :: Verbosity - -> PackageDB - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> [UnresolvedDependency] - -> IO () -fetch verbosity packageDB repos comp conf deps - = do installed <- getInstalledPackages verbosity comp packageDB conf - available <- getAvailablePackages verbosity repos - deps' <- IndexUtils.disambiguateDependencies available deps - case resolveDependencies buildOS buildArch (compilerId comp) - installed available PreferLatestForSelected deps' of - Left message -> die message - Right pkgs -> do - ps <- filterM (fmap not . isFetched) - [ pkg | (InstallPlan.Configured - (InstallPlan.ConfiguredPackage pkg _ _)) - <- InstallPlan.toList pkgs ] - mapM_ (fetchPackage verbosity) ps - -withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r -withBinaryFile name mode = bracket (openBinaryFile name mode) hClose - --- |Generate the full path to the locally cached copy of --- the tarball for a given @PackageIdentifer@. -packageFile :: AvailablePackage -> FilePath -packageFile pkg = packageDir pkg - display (packageId pkg) - <.> "tar.gz" - --- |Generate the full path to the directory where the local cached copy of --- the tarball for a given @PackageIdentifer@ is stored. -packageDir :: AvailablePackage -> FilePath -packageDir AvailablePackage { packageInfoId = p - , packageSource = RepoTarballPackage repo } = - repoCacheDir repo - pkgName p - display (pkgVersion p) - --- | Generate the URI of the tarball for a given package. -packageURI :: AvailablePackage -> URI -packageURI AvailablePackage { packageInfoId = p - , packageSource = RepoTarballPackage repo } = - (repoURI repo) { - uriPath = intercalate "/" - [uriPath (repoURI repo) , - pkgName p, display (pkgVersion p), - display p ++ ".tar.gz"] - } diff --git a/Hackage/HttpUtils.hs b/Hackage/HttpUtils.hs deleted file mode 100644 --- a/Hackage/HttpUtils.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | Separate module for HTTP actions, using a proxy server if one exists ------------------------------------------------------------------------------ -module Hackage.HttpUtils (getHTTP, proxy) where - -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..) ) -import Network.URI - ( URI (..), URIAuth (..), parseAbsoluteURI ) -import Network.Stream (Result) -import Network.Browser (Proxy (..), Authority (..), browse, - setOutHandler, setErrHandler, setProxy, request) -import Control.Monad - ( mplus, join ) -#ifdef WIN32 -import System.Win32.Types - ( DWORD, HKEY ) -import System.Win32.Registry - ( hKEY_CURRENT_USER, regOpenKey, regCloseKey - , regQueryValue, regQueryValueEx ) -import Control.Exception - ( handle, bracket ) -import Foreign - ( toBool, Storable(peek, sizeOf), castPtr, alloca ) -#else -import System.Environment (getEnvironment) -#endif - -import qualified Paths_cabal_install (version) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (warn, debug) -import Distribution.Text - ( display ) - --- FIXME: all this proxy stuff is far too complicated, especially parsing --- the proxy strings. Network.Browser should have a way to pick up the --- proxy settings hiding all this system-dependent stuff below. - --- try to read the system proxy settings on windows or unix -proxyString :: IO (Maybe String) -#ifdef WIN32 --- read proxy settings from the windows registry -proxyString = handle (\_ -> return Nothing) $ - bracket (regOpenKey hive path) regCloseKey $ \hkey -> do - enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" - if enable - then fmap Just $ regQueryValue hkey (Just "ProxyServer") - else return Nothing - where - -- some sources say proxy settings should be at - -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows - -- \CurrentVersion\Internet Settings\ProxyServer - -- but if the user sets them with IE connection panel they seem to - -- end up in the following place: - hive = hKEY_CURRENT_USER - path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" - - regQueryValueDWORD :: HKEY -> String -> IO DWORD - regQueryValueDWORD hkey name = alloca $ \ptr -> do - regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) - peek ptr -#else --- read proxy settings by looking for an env var -proxyString = do - env <- getEnvironment - return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) -#endif - --- |Get the local proxy settings -proxy :: Verbosity -> IO Proxy -proxy verbosity = do - mstr <- proxyString - case mstr of - Nothing -> return NoProxy - Just str -> case parseHttpProxy str of - Nothing -> do - warn verbosity $ "invalid http proxy uri: " ++ show str - warn verbosity $ "proxy uri must be http with a hostname" - warn verbosity $ "ignoring http proxy, trying a direct connection" - return NoProxy - Just p -> return p - --- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ --- which lack the @\"http://\"@ URI scheme. The problem is that --- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme --- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. --- --- So our strategy is to try parsing as normal uri first and if it lacks the --- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. --- -parseHttpProxy :: String -> Maybe Proxy -parseHttpProxy str = join - . fmap uri2proxy - $ parseHttpURI str - `mplus` parseHttpURI ("http://" ++ str) - where - parseHttpURI str' = case parseAbsoluteURI str' of - Just uri@URI { uriAuthority = Just _ } - -> Just uri - _ -> Nothing - -uri2proxy :: URI -> Maybe Proxy -uri2proxy uri@URI{ uriScheme = "http:" - , uriAuthority = Just (URIAuth auth' host port) - } = Just (Proxy (host ++ port) auth) - where auth = if null auth' - then Nothing - else Just (AuthBasic "" usr pwd uri) - (usr,pwd') = break (==':') auth' - pwd = case pwd' of - ':':cs -> cs - _ -> pwd' -uri2proxy _ = Nothing - -mkRequest :: URI -> Request -mkRequest uri = Request{ rqURI = uri - , rqMethod = GET - , rqHeaders = [Header HdrUserAgent userAgent] - , rqBody = "" } - where userAgent = "cabal-install/" ++ display Paths_cabal_install.version - --- |Carry out a GET request, using the local proxy settings -getHTTP :: Verbosity -> URI -> IO (Result Response) -getHTTP verbosity uri = do - p <- proxy verbosity - let req = mkRequest uri - (_, resp) <- browse $ do - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setProxy p - request req - return (Right resp) diff --git a/Hackage/IndexUtils.hs b/Hackage/IndexUtils.hs deleted file mode 100644 --- a/Hackage/IndexUtils.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.IndexUtils --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- Extra utils related to the package indexes. ------------------------------------------------------------------------------ -module Hackage.IndexUtils ( - getAvailablePackages, - readRepoIndex, - disambiguatePackageName, - disambiguateDependencies - ) where - -import Hackage.Tar -import Hackage.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..) ) - -import Distribution.Package (PackageIdentifier(..), Package(..), Dependency(Dependency)) -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.PackageDescription - ( parsePackageDescription ) -import Distribution.ParseUtils - ( ParseResult(..) ) -import Distribution.Text - ( simpleParse ) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) - -import Prelude hiding (catch) -import Data.Monoid (Monoid(mconcat)) -import Control.Exception (evaluate, catch, Exception(IOException)) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Data.ByteString.Lazy (ByteString) -import System.FilePath ((), takeExtension, splitDirectories, normalise) -import System.IO.Error (isDoesNotExistError) - - -getAvailablePackages :: Verbosity -> [Repo] - -> IO (PackageIndex AvailablePackage) -getAvailablePackages verbosity repos = do - info verbosity "Reading available packages..." - pkgss <- mapM (readRepoIndex verbosity) repos - evaluate (mconcat pkgss) - --- | Read a repository index from disk, from the local file specified by --- the 'Repo'. --- -readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage) -readRepoIndex verbosity repo = - let indexFile = repoCacheDir repo "00-index.tar" - in fmap parseRepoIndex (BS.readFile indexFile) - `catch` (\e -> do case e of - IOException ioe | isDoesNotExistError ioe -> - warn verbosity "The package list does not exist. Run 'cabal update' to download it." - _ -> warn verbosity (show e) - return (PackageIndex.fromList [])) - - where - -- | Parse a repository index file from a 'ByteString'. - -- - -- All the 'AvailablePackage's are marked as having come from the given 'Repo'. - -- - parseRepoIndex :: ByteString -> PackageIndex AvailablePackage - parseRepoIndex s = PackageIndex.fromList $ do - (hdr, content) <- readTarArchive s - if takeExtension (tarFileName hdr) == ".cabal" - then case splitDirectories (normalise (tarFileName hdr)) of - [pkgname,vers,_] -> - let parsed = parsePackageDescription - (fromUTF8 . BS.Char8.unpack $ content) - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " - ++ show (tarFileName hdr) - in case simpleParse vers of - Just ver -> return AvailablePackage { - packageInfoId = PackageIdentifier pkgname ver, - packageDescription = descr, - packageSource = RepoTarballPackage repo - } - _ -> [] - _ -> [] - else [] - --- | Disambiguate a set of packages using 'disambiguatePackage' and report any --- ambiguities to the user. --- -disambiguateDependencies :: PackageIndex AvailablePackage - -> [UnresolvedDependency] - -> IO [UnresolvedDependency] -disambiguateDependencies index deps = do - let names = [ (name, disambiguatePackageName index name) - | UnresolvedDependency (Dependency name _) _ <- deps ] - in case [ (name, matches) | (name, Right matches) <- names ] of - [] -> return - [ UnresolvedDependency (Dependency name vrange) flags - | (UnresolvedDependency (Dependency _ vrange) flags, - (_, Left name)) <- zip deps names ] - ambigious -> die $ unlines - [ if null matches - then "There is no package named " ++ name - else "The package name " ++ name ++ "is ambigious. " - ++ "It could be: " ++ intercalate ", " matches - | (name, matches) <- ambigious ] - --- | Given an index of known packages and a package name, figure out which one it --- might be referring to. If there is an exact case-sensitive match then that's --- ok. If it matches just one package case-insensitively then that's also ok. --- The only problem is if it matches multiple packages case-insensitively, in --- that case it is ambigious. --- -disambiguatePackageName :: PackageIndex AvailablePackage - -> String - -> Either String [String] -disambiguatePackageName index name = - case PackageIndex.searchByName index name of - PackageIndex.None -> Right [] - PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs))) - PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg) - | (pkg:_) <- pkgss ] diff --git a/Hackage/Install.hs b/Hackage/Install.hs deleted file mode 100644 --- a/Hackage/Install.hs +++ /dev/null @@ -1,346 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Install --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- High level interface to package installation. ------------------------------------------------------------------------------ -module Hackage.Install ( - install, - upgrade, - ) where - -import Data.List - ( unfoldr ) -import Control.Exception as Exception - ( handle, Exception ) -import Control.Monad - ( when, unless ) -import System.Directory - ( getTemporaryDirectory, doesFileExist ) -import System.FilePath ((),(<.>)) - -import Hackage.Dependency - ( resolveDependenciesWithProgress, PackagesVersionPreference(..) - , upgradableDependencies ) -import Hackage.Dependency.Types (Progress(..), foldProgress) -import Hackage.Fetch (fetchPackage) --- import qualified Hackage.Info as Info -import Hackage.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies ) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.InstallPlan (InstallPlan) -import Hackage.Setup - ( InstallFlags(..), configureCommand, filterConfigureFlags ) -import Hackage.Tar (extractTarGzFile) -import Hackage.Types as Available - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo, ConfiguredPackage(..) - , BuildResult(..) ) -import Hackage.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Hackage.Reporting - ( writeInstallPlanBuildReports ) -import Paths_cabal_install (getBinDir) - -import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDB(..) ) -import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) -import Distribution.Simple.Configure (getInstalledPackages) -import qualified Distribution.Simple.Setup as Cabal -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.Simple.Setup - ( flagToMaybe ) -import Distribution.Simple.Utils - ( defaultPackageDesc, inDir, rawSystemExit, withTempDirectory ) -import Distribution.Package - ( PackageIdentifier(..), Package(..), thisPackageVersion ) -import Distribution.PackageDescription as PackageDescription - ( GenericPackageDescription(packageDescription) - , readPackageDescription ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Version - ( Version, VersionRange(AnyVersion, ThisVersion) ) -import Distribution.Simple.Utils as Utils (notice, info, die) -import Distribution.System - ( buildOS, buildArch ) -import Distribution.Text - ( display ) -import Distribution.Verbosity (Verbosity, showForCabal, verbose) -import Distribution.Simple.BuildPaths ( exeExtension ) - -data InstallMisc = InstallMisc { - rootCmd :: Maybe FilePath, - libVersion :: Maybe Version - } - --- |Installs the packages needed to satisfy a list of dependencies. -install, upgrade - :: Verbosity - -> PackageDB - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> Cabal.ConfigFlags - -> InstallFlags - -> [UnresolvedDependency] - -> IO () -install verbosity packageDB repos comp conf configFlags installFlags deps = - installWithPlanner planner - verbosity packageDB repos comp conf configFlags installFlags - where - planner :: Planner - planner | null deps = planLocalPackage verbosity comp configFlags - | otherwise = planRepoPackages PreferLatestForSelected comp deps - -upgrade verbosity packageDB repos comp conf configFlags installFlags deps = - installWithPlanner planner - verbosity packageDB repos comp conf configFlags installFlags - where - planner :: Planner - planner | null deps = planUpgradePackages comp - | otherwise = planRepoPackages PreferAllLatest comp deps - -type Planner = Maybe (PackageIndex InstalledPackageInfo) - -> PackageIndex AvailablePackage - -> IO (Progress String String (InstallPlan BuildResult)) - --- |Installs the packages generated by a planner. -installWithPlanner :: - Planner - -> Verbosity - -> PackageDB - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> Cabal.ConfigFlags - -> InstallFlags - -> IO () -installWithPlanner planner verbosity packageDB repos comp conf configFlags installFlags = do - installed <- getInstalledPackages verbosity comp packageDB conf - available <- getAvailablePackages verbosity repos - - progress <- planner installed available - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) - (return . Left) (return . Right) progress - case maybePlan of - Left message -> die message - Right installPlan -> do - when (dryRun || verbosity >= verbose) $ - printDryRun verbosity installPlan - - unless dryRun $ do - installPlan' <- - executeInstallPlan installPlan $ \cpkg -> - installConfiguredPackage configFlags cpkg $ \configFlags' apkg -> - installAvailablePackage verbosity apkg $ - installUnpackedPackage verbosity (setupScriptOptions installed) - miscOptions configFlags' - writeInstallPlanBuildReports installPlan' - printBuildFailures installPlan' - - where - setupScriptOptions index = SetupScriptOptions { - useCabalVersion = maybe AnyVersion ThisVersion (libVersion miscOptions), - useCompiler = Just comp, - usePackageIndex = if packageDB == UserPackageDB then index else Nothing, - useProgramConfig = conf, - useDistPref = Cabal.fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (Cabal.configDistPref configFlags) - } - dryRun = Cabal.fromFlag (installDryRun installFlags) - miscOptions = InstallMisc { - rootCmd = if Cabal.fromFlag (Cabal.configUserInstall configFlags) - then Nothing -- ignore --root-cmd if --user. - else Cabal.flagToMaybe (installRootCmd installFlags), - libVersion = Cabal.flagToMaybe (installCabalVersion installFlags) - } - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner -planLocalPackage verbosity comp configFlags installed available = do - pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity - let -- The trick is, we add the local package to the available index and - -- remove it from the installed index. Then we ask to resolve a - -- dependency on exactly that package. So the resolver ends up having - -- to pick the local package. - available' = PackageIndex.insert localPkg available - installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed - localPkg = AvailablePackage { - packageInfoId = packageId pkg, - Available.packageDescription = pkg, - packageSource = LocalUnpackedPackage - } - localPkgDep = UnresolvedDependency { - dependency = thisPackageVersion (packageId localPkg), - depFlags = Cabal.configConfigurationsFlags configFlags - } - - return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - installed' available' PreferLatestForSelected [localPkgDep] - --- | Make an 'InstallPlan' for the given dependencies. --- -planRepoPackages :: PackagesVersionPreference -> Compiler - -> [UnresolvedDependency] -> Planner -planRepoPackages pref comp deps installed available = do - deps' <- IndexUtils.disambiguateDependencies available deps - return $ resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - installed available pref deps' - -planUpgradePackages :: Compiler -> Planner -planUpgradePackages comp (Just installed) available = return $ - resolveDependenciesWithProgress buildOS buildArch (compilerId comp) - (Just installed) available PreferAllLatest - [ UnresolvedDependency dep [] - | dep <- upgradableDependencies installed available ] -planUpgradePackages comp _ _ = - die $ display (compilerId comp) - ++ " does not track installed packages so cabal cannot figure out what" - ++ " packages need to be upgraded." - -printDryRun :: Verbosity -> InstallPlan BuildResult -> IO () -printDryRun verbosity plan = case unfoldr next plan of - [] -> notice verbosity "No packages to be installed." - pkgs -> notice verbosity $ unlines $ - "In order, the following would be installed:" - : map display pkgs - where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid plan') - where pkgid = packageId pkg - -printBuildFailures :: InstallPlan BuildResult -> IO () -printBuildFailures plan = - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of - [] -> return () - failed -> die . unlines - $ "Error: some packages failed to install:" - : [ display (packageId pkg) ++ printFailureReason reason - | (pkg, reason) <- failed ] - where - printFailureReason reason = case reason of - DependentFailed pkgid -> " depends on " ++ display pkgid - ++ " which failed to install." - UnpackFailed e -> " failed while unpacking the package." - ++ " The exception was:\n " ++ show e - ConfigureFailed e -> " failed during the configure step." - ++ " The exception was:\n " ++ show e - BuildFailed e -> " failed during the building phase." - ++ " The exception was:\n " ++ show e - InstallFailed e -> " failed during the final install step." - ++ " The exception was:\n " ++ show e - _ -> "" - -executeInstallPlan :: Monad m - => InstallPlan BuildResult - -> (ConfiguredPackage -> m BuildResult) - -> m (InstallPlan BuildResult) -executeInstallPlan plan installPkg = case InstallPlan.ready plan of - [] -> return plan - (pkg: _) -> do - buildResult <- installPkg pkg - let pkgid = packageId pkg - updatePlan = case buildResult of - BuildOk -> InstallPlan.completed pkgid - _ -> InstallPlan.failed pkgid buildResult depsResult - where depsResult = DependentFailed pkgid - -- So this first pkgid failed for whatever reason (buildResult) - -- all the other packages that depended on this pkgid which we - -- now cannot build we mark as failing due to DependentFailed - -- which kind of means it was not their fault. - executeInstallPlan (updatePlan plan) installPkg - --- | Call an installer for an 'AvailablePackage' but override the configure --- flags with the ones given by the 'ConfiguredPackage'. In particular the --- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- -installConfiguredPackage :: Cabal.ConfigFlags -> ConfiguredPackage - -> (Cabal.ConfigFlags -> AvailablePackage -> a) - -> a -installConfiguredPackage configFlags (ConfiguredPackage pkg flags deps) - installPkg = installPkg configFlags { - Cabal.configConfigurationsFlags = flags, - Cabal.configConstraints = map thisPackageVersion deps - } pkg - -installAvailablePackage - :: Verbosity -> AvailablePackage - -> (GenericPackageDescription -> Maybe FilePath -> IO BuildResult) - -> IO BuildResult -installAvailablePackage _ (AvailablePackage _ pkg LocalUnpackedPackage) - installPkg = installPkg pkg Nothing - -installAvailablePackage verbosity apkg@(AvailablePackage _ pkg _) - installPkg = do - pkgPath <- fetchPackage verbosity apkg - tmp <- getTemporaryDirectory - let pkgid = packageId pkg - tmpDirPath = tmp ("TMP" ++ display pkgid) - path = tmpDirPath display pkgid - onFailure UnpackFailed $ withTempDirectory verbosity tmpDirPath $ do - info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ tmpDirPath ++ "..." - extractTarGzFile tmpDirPath pkgPath - let descFilePath = tmpDirPath display pkgid - pkgName pkgid <.> "cabal" - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath - installPkg pkg (Just path) - -installUnpackedPackage :: Verbosity - -> SetupScriptOptions - -> InstallMisc - -> Cabal.ConfigFlags - -> GenericPackageDescription - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> IO BuildResult -installUnpackedPackage verbosity scriptOptions miscOptions configFlags pkg mpath - = onFailure ConfigureFailed $ do - setup configureCommand (filterConfigureFlags configFlags) - onFailure BuildFailed $ do - setup buildCommand (const Cabal.emptyBuildFlags) - onFailure InstallFailed $ do - case rootCmd miscOptions of - (Just cmd) -> reexec cmd - Nothing -> setup Cabal.installCommand - (const Cabal.emptyInstallFlags) - return BuildOk - where - buildCommand = Cabal.buildCommand defaultProgramConfiguration - setup cmd flags = inDir mpath $ - setupWrapper verbosity scriptOptions - (Just $ PackageDescription.packageDescription 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: - bindir <- getBinDir - let self = bindir "cabal" <.> exeExtension - weExist <- doesFileExist self - if weExist - then inDir mpath $ - rawSystemExit verbosity cmd - [self, "install", "--only" - ,"--verbose=" ++ showForCabal verbosity] - else die $ "Unable to find cabal executable at: " ++ self - --- helper -onFailure :: (Exception -> BuildResult) -> IO BuildResult -> IO BuildResult -onFailure result = Exception.handle (return . result) diff --git a/Hackage/InstallPlan.hs b/Hackage/InstallPlan.hs deleted file mode 100644 --- a/Hackage/InstallPlan.hs +++ /dev/null @@ -1,497 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.InstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- Package installation plan --- ------------------------------------------------------------------------------ -module Hackage.InstallPlan ( - InstallPlan, - ConfiguredPackage(..), - PlanPackage(..), - - -- * Operations on 'InstallPlan's - new, - toList, - ready, - completed, - failed, - - -- ** Query functions - planOS, - planArch, - planCompiler, - - -- * Checking valididy of plans - valid, - closed, - consistent, - acyclic, - configuredPackageValid, - - -- ** Details on invalid plans - PlanProblem(..), - showPlanProblem, - PackageProblem(..), - showPackageProblem, - problems, - configuredPackageProblems - ) where - -import Hackage.Types - ( AvailablePackage(packageDescription), ConfiguredPackage(..) ) -import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) - , packageName, Dependency(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.PackageDescription - ( GenericPackageDescription(genPackageFlags) - , PackageDescription(buildDepends) - , Flag(flagName), FlagName(..) ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Simple.PackageIndex - ( PackageIndex ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Text - ( display ) -import Distribution.System - ( OS, Arch ) -import Distribution.Compiler - ( CompilerId(..) ) -import Hackage.Utils - ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) -import Distribution.Simple.Utils - ( comparing, intercalate ) - -import Data.List - ( sort, sortBy ) -import Data.Maybe - ( fromMaybe ) -import qualified Data.Graph as Graph -import Data.Graph (Graph) -import Control.Exception - ( assert ) - --- When cabal tries to install a number of packages, including all their --- dependencies it has a non-trivial problem to solve. --- --- The Problem: --- --- In general we start with a set of installed packages and a set of available --- packages. --- --- Installed packages have fixed dependencies. They have already been built and --- we know exactly what packages they were built against, including their exact --- versions. --- --- Available package have somewhat flexible dependencies. They are specified as --- version ranges, though really they're predicates. To make matters worse they --- have conditional flexible dependencies. Configuration flags can affect which --- packages are required and can place additional constraints on their --- versions. --- --- These two sets of package can and usually do overlap. There can be installed --- packages that are also available which means they could be re-installed if --- required, though there will also be packages which are not available and --- cannot be re-installed. Very often there will be extra versions available --- than are installed. Sometimes we may like to prefer installed packages over --- available ones or perhaps always prefer the latest available version whether --- installed or not. --- --- The goal is to calculate an installation plan that is closed, acyclic and --- consistent and where every configured package is valid. --- --- An installation plan is a set of packages that are going to be used --- together. It will consist of a mixture of installed packages and available --- packages along with their exact version dependencies. An installation plan --- is closed if for every package in the set, all of its dependencies are --- also in the set. It is consistent if for every package in the set, all --- dependencies which target that package have the same version. - --- 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 --- have problems with inconsistent dependencies. --- On the other hand it is true that every closed sub plan is valid. - -data PlanPackage buildResult = PreExisting InstalledPackageInfo - | Configured ConfiguredPackage - | Installed ConfiguredPackage - | Failed ConfiguredPackage buildResult - deriving Show - -instance Package (PlanPackage buildResult) where - packageId (PreExisting pkg) = packageId pkg - packageId (Configured pkg) = packageId pkg - packageId (Installed pkg) = packageId pkg - packageId (Failed pkg _) = packageId pkg - -instance PackageFixedDeps (PlanPackage buildResult) where - depends (PreExisting pkg) = depends pkg - depends (Configured pkg) = depends pkg - depends (Installed pkg) = depends pkg - depends (Failed pkg _) = depends pkg - -data InstallPlan buildResult = InstallPlan { - planIndex :: PackageIndex (PlanPackage buildResult), - planGraph :: Graph, - planGraphRev :: Graph, - planPkgIdOf :: Graph.Vertex -> PackageIdentifier, - planVertexOf :: PackageIdentifier -> Graph.Vertex, - planOS :: OS, - planArch :: Arch, - planCompiler :: CompilerId - } - -invariant :: InstallPlan a -> Bool -invariant plan = - valid (planOS plan) (planArch plan) (planCompiler plan) (planIndex plan) - -internalError :: String -> a -internalError msg = error $ "InstallPlan: internal error: " ++ msg - --- | Build an installation plan from a valid set of resolved packages. --- -new :: OS -> Arch -> CompilerId -> PackageIndex (PlanPackage a) - -> Either [PlanProblem a] (InstallPlan a) -new os arch compiler index = - case problems os arch compiler index of - [] -> Right InstallPlan { - planIndex = index, - planGraph = graph, - planGraphRev = Graph.transposeG graph, - planPkgIdOf = vertexToPkgId, - planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, - planOS = os, - planArch = arch, - planCompiler = compiler - } - where (graph, vertexToPkgId, pkgIdToVertex) = - PackageIndex.dependencyGraph index - noSuchPkgId = internalError "package is not in the graph" - probs -> Left probs - -toList :: InstallPlan buildResult -> [PlanPackage buildResult] -toList = PackageIndex.allPackages . planIndex - --- | The packages that are ready to be installed. That is they are in the --- configured state and have all their dependencies installed already. --- The plan is complete if the result is @[]@. --- -ready :: InstallPlan buildResult -> [ConfiguredPackage] -ready plan = assert check readyPackages - where - check = if null readyPackages then null configuredPackages else True - configuredPackages = - [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] - readyPackages = filter (all isInstalled . depends) configuredPackages - isInstalled pkg = - case PackageIndex.lookupPackageId (planIndex plan) pkg of - Just (Configured _) -> False - Just (Failed _ _) -> internalError depOnFailed - Just (PreExisting _) -> True - Just (Installed _) -> True - Nothing -> internalError incomplete - incomplete = "install plan is not closed" - depOnFailed = "configured package depends on failed package" - --- | 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 have had no uninstalled dependent packages. --- -completed :: PackageIdentifier - -> InstallPlan buildResult -> InstallPlan buildResult -completed pkgid plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = PackageIndex.insert installed (planIndex plan) - } - installed = Installed (lookupConfiguredPackage plan pkgid) - --- | 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. --- -failed :: PackageIdentifier -- ^ The id of the package that failed to install - -> buildResult -- ^ The build result to use for the failed package - -> buildResult -- ^ The build result to use for its dependencies - -> InstallPlan buildResult - -> InstallPlan buildResult -failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = PackageIndex.merge (planIndex plan) failures - } - pkg = lookupConfiguredPackage plan pkgid - failures = PackageIndex.fromList - $ Failed pkg buildResult - : [ Failed pkg' buildResult' - | Just pkg' <- map (lookupConfiguredPackage' plan) - $ packagesThatDependOn plan pkgid ] - --- | lookup the reachable packages in the reverse dependency graph --- -packagesThatDependOn :: InstallPlan a - -> PackageIdentifier -> [PackageIdentifier] -packagesThatDependOn plan = map (planPkgIdOf plan) - . tail - . Graph.reachable (planGraphRev plan) - . planVertexOf plan - --- | lookup a package that we expect to be in the configured state --- -lookupConfiguredPackage :: InstallPlan a - -> PackageIdentifier -> ConfiguredPackage -lookupConfiguredPackage plan pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of - Just (Configured pkg) -> pkg - _ -> internalError $ "not configured or no such pkg " ++ display pkgid - --- | lookup a package that we expect to be in the configured or failed state --- -lookupConfiguredPackage' :: InstallPlan a - -> PackageIdentifier -> Maybe ConfiguredPackage -lookupConfiguredPackage' plan pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of - Just (Configured pkg) -> Just pkg - Just (Failed _ _) -> Nothing - _ -> internalError $ "not configured or no such pkg " ++ display pkgid - --- ------------------------------------------------------------ --- * Checking valididy of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: OS -> Arch -> CompilerId -> PackageIndex (PlanPackage a) -> Bool -valid os arch comp index = null (problems os arch comp index) - -data PlanProblem a = - PackageInvalid ConfiguredPackage [PackageProblem] - | PackageMissingDeps (PlanPackage a) [PackageIdentifier] - | PackageCycle [PlanPackage a] - | PackageInconsistency String [(PackageIdentifier, Version)] - | PackageStateInvalid (PlanPackage a) (PlanPackage a) - -showPlanProblem :: PlanProblem a -> String -showPlanProblem (PackageInvalid pkg packageProblems) = - "Package " ++ display (packageId pkg) - ++ " has an invalid configuration, in particular:\n" - ++ unlines [ " " ++ showPackageProblem problem - | problem <- packageProblems ] - -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ display (packageId pkg) - ++ " depends on the following packages which are missing from the plan " - ++ intercalate ", " (map display missingDeps) - -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (display.packageId) cycleGroup) - -showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ display (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ display (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" - where - showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" - showPlanState (Installed _) = "installed" - showPlanState (Failed _ _) = "failed" - --- | For an invalid plan, produce a detailed list of problems as human readable --- error messages. This is mainly intended for debugging purposes. --- Use 'showPlanProblem' for a human readable explanation. --- -problems :: OS -> Arch -> CompilerId - -> PackageIndex (PlanPackage a) -> [PlanProblem a] -problems os arch comp index = - [ PackageInvalid pkg packageProblems - | Configured pkg <- PackageIndex.allPackages index - , let packageProblems = configuredPackageProblems os arch comp pkg - , not (null packageProblems) ] - - ++ [ PackageMissingDeps pkg missingDeps - | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- PackageIndex.dependencyCycles index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- PackageIndex.allPackages index - , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) - , not (stateDependencyRelation pkg pkg') ] - --- | The graph of packages (nodes) and dependencies (edges) must be acyclic. --- --- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --- which packages are involved in dependency cycles. --- -acyclic :: PackageIndex (PlanPackage a) -> Bool -acyclic = null . PackageIndex.dependencyCycles - --- | An installation plan is closed if for every package in the set, all of --- its dependencies are also in the set. That is, the set is closed under the --- dependency relation. --- --- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --- which packages depend on packages not in the index. --- -closed :: PackageIndex (PlanPackage a) -> Bool -closed = null . PackageIndex.brokenPackages - --- | An installation plan is consistent if all dependencies that target a --- single package name, target the same version. --- --- This is slightly subtle. It is not the same as requiring that there be at --- most one version of any package in the set. It only requires that of --- packages which have more than one other package depending on them. We could --- actually make the condition even more precise and say that different --- versions are ok so long as they are not both in the transative closure of --- any other package (or equivalently that their inverse closures do not --- intersect). The point is we do not want to have any packages depending --- directly or indirectly on two different versions of the same package. The --- current definition is just a safe aproximation of that. --- --- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --- find out which packages are. --- -consistent :: PackageIndex (PlanPackage a) -> Bool -consistent = null . PackageIndex.dependencyInconsistencies - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: PlanPackage a -> PlanPackage a -> Bool -stateDependencyRelation (PreExisting _) (PreExisting _) = True - -stateDependencyRelation (Configured _) (PreExisting _) = True -stateDependencyRelation (Configured _) (Configured _) = True -stateDependencyRelation (Configured _) (Installed _) = True - -stateDependencyRelation (Installed _) (PreExisting _) = True -stateDependencyRelation (Installed _) (Installed _) = True - -stateDependencyRelation (Failed _ _) (PreExisting _) = True --- failed can depends on configured because a package can depend on --- 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 _ _) (Installed _) = True -stateDependencyRelation (Failed _ _) (Failed _ _) = True - -stateDependencyRelation _ _ = False - --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if --- in the configuration given by the flag assignment, all the package --- dependencies are satisfied by the specified packages. --- -configuredPackageValid :: OS -> Arch -> CompilerId -> ConfiguredPackage -> Bool -configuredPackageValid os arch comp pkg = - null (configuredPackageProblems os arch comp pkg) - -data PackageProblem = DuplicateFlag FlagName - | MissingFlag FlagName - | ExtraFlag FlagName - | DuplicateDeps [PackageIdentifier] - | MissingDep Dependency - | ExtraDep PackageIdentifier - | InvalidDep Dependency PackageIdentifier - -showPackageProblem :: PackageProblem -> String -showPackageProblem (DuplicateFlag (FlagName flag)) = - "duplicate flag in the flag assignment: " ++ flag - -showPackageProblem (MissingFlag (FlagName flag)) = - "missing an assignment for the flag: " ++ flag - -showPackageProblem (ExtraFlag (FlagName flag)) = - "extra flag given that is not used by the package: " ++ flag - -showPackageProblem (DuplicateDeps pkgids) = - "duplicate packages specified as selected dependencies: " - ++ intercalate ", " (map display pkgids) - -showPackageProblem (MissingDep dep) = - "the package has a dependency " ++ display dep - ++ " but no package has been selected to satisfy it." - -showPackageProblem (ExtraDep pkgid) = - "the package configuration specifies " ++ display pkgid - ++ " but (with the given flag assignment) the package does not actually" - ++ " depend on any version of that package." - -showPackageProblem (InvalidDep dep pkgid) = - "the package depends on " ++ display dep - ++ " but the configuration specifies " ++ display pkgid - ++ " which does not satisfy the dependency." - -configuredPackageProblems :: OS -> Arch -> CompilerId - -> ConfiguredPackage -> [PackageProblem] -configuredPackageProblems os arch comp - (ConfiguredPackage pkg specifiedFlags specifiedDeps) = - [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] - ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] - ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] - ++ [ DuplicateDeps pkgs - | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] - ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] - ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] - ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps - , not (packageSatisfiesDependency pkgid dep) ] - where - mergedFlags = mergeBy compare - (sort $ map flagName (genPackageFlags (packageDescription pkg))) - (sort $ map fst specifiedFlags) - - mergedDeps = mergeBy - (\dep pkgid -> dependencyName dep `compare` packageName pkgid) - (sortBy (comparing dependencyName) requiredDeps) - (sortBy (comparing packageName) specifiedDeps) - - packageSatisfiesDependency - (PackageIdentifier name version) - (Dependency name' versionRange) = assert (name == name') $ - version `withinRange` versionRange - - dependencyName (Dependency name _) = name - - requiredDeps :: [Dependency] - requiredDeps = - --TODO: use something lower level than finalizePackageDescription - case finalizePackageDescription specifiedFlags - (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp [] - (packageDescription pkg) of - Right (resolvedPkg, _) -> buildDepends resolvedPkg - Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/Hackage/List.hs b/Hackage/List.hs deleted file mode 100644 --- a/Hackage/List.hs +++ /dev/null @@ -1,181 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Install --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- High level interface to package installation. ------------------------------------------------------------------------------ -module Hackage.List ( - list - ) where - -import Data.List (sortBy, groupBy, sort, nub, intersperse) -import Data.Maybe (listToMaybe, fromJust) -import Control.Monad (MonadPlus(mplus)) -import Control.Exception (assert) - -import Text.PrettyPrint.HughesPJ -import Distribution.Text - ( Text(disp), display ) - -import Distribution.Package (PackageIdentifier(..), Package(..)) -import Distribution.License (License) -import qualified Distribution.PackageDescription as Available -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Version (Version) -import Distribution.Verbosity (Verbosity) - -import Hackage.IndexUtils (getAvailablePackages) -import Hackage.Setup (ListFlags(..)) -import Hackage.Types (AvailablePackage(..), Repo) -import Distribution.Simple.Configure (getInstalledPackages) -import Distribution.Simple.Compiler (Compiler,PackageDB) -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.Simple.Utils (equating, comparing, notice) -import Distribution.Simple.Setup (fromFlag) - -import Hackage.Utils (mergeBy, MergeResult(..)) - --- |Show information about packages -list :: Verbosity - -> PackageDB - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ListFlags - -> [String] - -> IO () -list verbosity packageDB repos comp conf listFlags pats = do - Just installed <- getInstalledPackages verbosity comp packageDB conf - available <- getAvailablePackages verbosity repos - let pkgs | null pats = (PackageIndex.allPackages installed - ,PackageIndex.allPackages available) - | otherwise = - (concatMap (PackageIndex.searchByNameSubstring installed) pats - ,concatMap (PackageIndex.searchByNameSubstring available) pats) - matches = installedFilter - . map (uncurry mergePackageInfo) - $ uncurry mergePackages pkgs - - if simpleOutput - then putStr $ unlines - [ name pkg ++ " " ++ display version - | pkg <- matches - , version <- if onlyInstalled - then installedVersions pkg - else nub . sort $ installedVersions pkg - ++ availableVersions pkg ] - else - if null matches - then notice verbosity "No matches found." - else putStr $ unlines (map showPackageInfo matches) - where - installedFilter - | onlyInstalled = filter (not . null . installedVersions) - | otherwise = id - onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - --- | The info that we can display for each package. It is information per --- package name and covers all installed and avilable versions. --- -data PackageDisplayInfo = PackageDisplayInfo { - name :: String, - installedVersions :: [Version], - availableVersions :: [Version], - homepage :: String, - category :: String, - synopsis :: String, - license :: License - } - -showPackageInfo :: PackageDisplayInfo -> String -showPackageInfo pkg = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - text " *" <+> text (name pkg) - $+$ - (nest 6 $ vcat [ - maybeShow (availableVersions pkg) - "Latest version available:" - (disp . maximum) - , maybeShow (installedVersions pkg) - "Latest version installed:" - (disp . maximum) - , maybeShow (homepage pkg) "Homepage:" text - , maybeShow (category pkg) "Category:" text - , maybeShow (synopsis pkg) "Synopsis:" reflowParas - , text "License: " <+> text (show (license pkg)) - ]) - $+$ text "" - where - maybeShow [] _ _ = empty - maybeShow l s f = text s <+> (f l) - reflowParas = vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paras - . filter (/= [""]) - . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines - --- | We get the 'PackageDisplayInfo' by combining the info for the installed --- and available versions of a package. --- --- * We're building info about a various versions of a single named package so --- the input package info records are all supposed to refer to the same --- package name. --- -mergePackageInfo :: [InstalledPackageInfo] - -> [AvailablePackage] - -> PackageDisplayInfo -mergePackageInfo installed available = - assert (length installed + length available > 0) $ - PackageDisplayInfo { - name = combine (pkgName . packageId) latestAvailable - (pkgName . packageId) latestInstalled, - installedVersions = map (pkgVersion . packageId) installed, - availableVersions = map (pkgVersion . packageId) available, - homepage = combine Available.homepage latestAvailableDesc - Installed.homepage latestInstalled, - category = combine Available.category latestAvailableDesc - Installed.category latestInstalled, - synopsis = combine Available.synopsis latestAvailableDesc - Installed.description latestInstalled, - license = combine Available.license latestAvailableDesc - Installed.license latestInstalled - } - where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) - latestInstalled = latestOf installed - latestAvailable = latestOf available - latestAvailableDesc = fmap (Available.packageDescription . packageDescription) - latestAvailable - latestOf :: Package pkg => [pkg] -> Maybe pkg - latestOf = listToMaybe . sortBy (comparing (pkgVersion . packageId)) - --- | Rearrange installed and available packages into groups referring to the --- same package by name. In the result pairs, the lists are guaranteed to not --- both be empty. --- -mergePackages :: [InstalledPackageInfo] -> [AvailablePackage] - -> [([InstalledPackageInfo], [AvailablePackage])] -mergePackages installed available = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn (pkgName . packageId) installed) - (groupOn (pkgName . packageId) available) - where - collect (OnlyInLeft (_,is) ) = (is, []) - collect ( InBoth (_,is) (_,as)) = (is, as) - collect (OnlyInRight (_,as)) = ([], as) - -groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] -groupOn key = map (\xs -> (key (head xs), xs)) - . groupBy (equating key) - . sortBy (comparing key) diff --git a/Hackage/ParseUtils.hs b/Hackage/ParseUtils.hs deleted file mode 100644 --- a/Hackage/ParseUtils.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Hackage.ParseUtils where - -import Distribution.Compat.ReadP - ( ReadP, readP_to_S, pfail, get, look, choice, (+++) ) -import Distribution.Package (PackageIdentifier(..), Dependency(..)) -import Distribution.ParseUtils - ( Field(..), FieldDescr(..), ParseResult(..), PError - , field, liftField, readFields - , warning, lineNo, locatedErrorMsg) -import Distribution.Text - ( Text(parse) ) -import Distribution.Version (Version(..), VersionRange(..)) - -import Control.Monad (foldM, liftM) -import Data.Char (isSpace, toLower) -import Data.Maybe (listToMaybe) -import Text.PrettyPrint.HughesPJ (Doc, render, vcat, text, (<>), (<+>)) - - -showPError :: PError -> String -showPError err = let (ml,msg) = locatedErrorMsg err - in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg - - - -readPToMaybe :: ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ] - -ignoreWarnings :: ParseResult a -> ParseResult a -ignoreWarnings (ParseOk _ x) = ParseOk [] x -ignoreWarnings r = r - -parseBasicStanza :: [FieldDescr a] -> a -> String -> ParseResult a -parseBasicStanza fields empty inp = - readFields inp >>= foldM (setField fields) empty - -setField :: [FieldDescr a] - -> a - -> Field - -> ParseResult a -setField fs x (F line f val) = - case lookupFieldDescr fs f of - Nothing -> - do warning ("Unrecognized field " ++ f ++ " on line " ++ show line) - return x - Just (FieldDescr _ _ set) -> set line val x -setField _ x s = - do warning ("Unrecognized stanza on line " ++ show (lineNo s)) - return x - -lookupFieldDescr :: [FieldDescr a] -> String -> Maybe (FieldDescr a) -lookupFieldDescr fs n = listToMaybe [f | f@(FieldDescr name _ _) <- fs, name == n] - -boolField :: String -> (a -> Bool) -> (Bool -> a -> a) -> FieldDescr a -boolField name g s = liftField g s $ field name showBool readBool - where - showBool :: Bool -> Doc - showBool True = text "true" - showBool False = text "false" - - readBool :: ReadP r Bool - readBool = choice [ stringNoCase "true" >> return True - , stringNoCase "false" >> return False - , stringNoCase "yes" >> return True - , stringNoCase "no" >> return False] - -showFields :: [FieldDescr a] -> a -> String -showFields fs x = render $ vcat [ text name <> text ":" <+> g x | FieldDescr name g _ <- fs] - - -stringNoCase :: String -> ReadP r String -stringNoCase this = look >>= scan this - where - scan [] _ = return this - scan (x:xs) (y:ys) | toLower x == toLower y = get >> scan xs ys - scan _ _ = pfail - -parseDependencyOrPackageId :: ReadP r Dependency -parseDependencyOrPackageId = parse +++ liftM pkgToDep parse - where pkgToDep p = case pkgVersion p of - Version [] _ -> Dependency (pkgName p) AnyVersion - version -> Dependency (pkgName p) (ThisVersion version) diff --git a/Hackage/Reporting.hs b/Hackage/Reporting.hs deleted file mode 100644 --- a/Hackage/Reporting.hs +++ /dev/null @@ -1,318 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Report data structure --- ------------------------------------------------------------------------------ -module Hackage.Reporting ( - BuildReport(..), - InstallOutcome(..), - Outcome(..), - - -- * Constructing and writing reports - buildReport, - writeBuildReports, - - -- * parsing and pretty printing - parseBuildReport, - parseBuildReports, - showBuildReport, - - -- * 'InstallPlan' variants - planPackageBuildReport, - installPlanBuildReports, - writeInstallPlanBuildReports - ) where - -import Hackage.Types - ( ConfiguredPackage(..), AvailablePackage(..) - , AvailablePackageSource(..), BuildResult - , Repo(repoCacheDir), repoName ) -import qualified Hackage.Types as BR - ( BuildResult(..) ) -import qualified Hackage.InstallPlan as InstallPlan -import Hackage.InstallPlan - ( InstallPlan, PlanPackage ) -import Hackage.ParseUtils - ( showFields, parseBasicStanza ) -import qualified Paths_cabal_install (version) - -import Distribution.Package - ( PackageIdentifier(PackageIdentifier), Package(packageId) ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) ---import Distribution.Version --- ( Version ) -import Distribution.System - ( OS, Arch ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.Text - ( Text(disp, parse) ) -import Distribution.ParseUtils - ( FieldDescr(..), ParseResult(..), simpleField, listField ) -import qualified Distribution.Compat.ReadP as Parse - ( ReadP, pfail, munch1, char, option, skipSpaces ) -import Text.PrettyPrint.HughesPJ as Disp - ( Doc, char, text, (<+>), (<>) ) -import Distribution.Simple.Utils - ( comparing, equating ) - -import Data.List - ( unfoldr, groupBy, sortBy ) -import Data.Maybe - ( catMaybes ) -import Data.Char as Char - ( isAlpha, isAlphaNum ) -import System.FilePath - ( () ) - -data BuildReport - = BuildReport { - -- | The package this build report is about - package :: PackageIdentifier, - - -- | The OS and Arch the package was built on - os :: OS, - arch :: Arch, - - -- | The Haskell compiler (and hopefully version) used - compiler :: CompilerId, - - -- | The uploading client, ie cabal-install-x.y.z - client :: PackageIdentifier, - - -- | Which configurations flags we used - flagAssignment :: FlagAssignment, - - -- | Which dependent packages we were using exactly - dependencies :: [PackageIdentifier], - - -- | Did installing work ok? - installOutcome :: InstallOutcome, - - -- | Which version of the Cabal library was used to compile the Setup.hs --- cabalVersion :: Version, - - -- | Which build tools we were using (with versions) --- tools :: [PackageIdentifier], - - -- | Configure outcome, did configure work ok? - docsOutcome :: Outcome, - - -- | Configure outcome, did configure work ok? - testsOutcome :: Outcome - } - -data InstallOutcome - = DependencyFailed PackageIdentifier - | DownloadFailed - | UnpackFailed - | SetupFailed - | ConfigureFailed - | BuildFailed - | InstallFailed - | InstallOk - -data Outcome = NotTried | Failed | Ok - -writeBuildReports :: [(BuildReport, Repo)] -> IO () -writeBuildReports reports = sequence_ - [ appendFile file (concatMap format reports') - | (repo, reports') <- separate reports - , let file = repoCacheDir repo "build-reports.log" ] - --TODO: make this concurrency safe, either lock the report file or make sure - -- the writes for each report are atomic (under 4k and flush at boundaries) - - where - format r = '\n' : showBuildReport r ++ "\n" - separate :: [(BuildReport, Repo)] -> [(Repo, [BuildReport])] - separate = map (\rs@((_,repo):_) -> (repo, map fst rs)) - . map concat - . groupBy (equating (repoName . snd . head)) - . sortBy (comparing (repoName . snd . head)) - . groupBy (equating (repoName . snd)) - -buildReport :: OS -> Arch -> CompilerId -- -> Version - -> ConfiguredPackage -> BR.BuildResult - -> BuildReport -buildReport os' arch' comp (ConfiguredPackage pkg flags deps) result = - BuildReport { - package = packageId pkg, - os = os', - arch = arch', - compiler = comp, - client = cabalInstallID, - flagAssignment = flags, - dependencies = deps, - installOutcome = case result of - BR.DependentFailed p -> DependencyFailed p - BR.UnpackFailed _ -> UnpackFailed - BR.ConfigureFailed _ -> ConfigureFailed - BR.BuildFailed _ -> BuildFailed - BR.InstallFailed _ -> InstallFailed - BR.BuildOk -> InstallOk, --- cabalVersion = undefined - docsOutcome = NotTried, - testsOutcome = NotTried - } - where - cabalInstallID = - PackageIdentifier "cabal-install" Paths_cabal_install.version - --- ------------------------------------------------------------ --- * External format --- ------------------------------------------------------------ - -initialBuildReport :: BuildReport -initialBuildReport = BuildReport { - package = requiredField "package", - os = requiredField "os", - arch = requiredField "arch", - compiler = requiredField "compiler", - client = requiredField "client", - flagAssignment = [], - dependencies = [], - installOutcome = requiredField "install-outcome", --- cabalVersion = Nothing, --- tools = [], - docsOutcome = NotTried, - testsOutcome = NotTried - } - where - requiredField fname = error ("required field: " ++ fname) - --- ----------------------------------------------------------------------------- --- Parsing - -parseBuildReport :: String -> ParseResult BuildReport -parseBuildReport = parseBasicStanza fieldDescrs initialBuildReport - -parseBuildReports :: String -> [BuildReport] -parseBuildReports str = - [ report | ParseOk [] report <- map parseBuildReport (split str) ] - - where - split :: String -> [String] - split = filter (not . null) . unfoldr chunk . lines - chunk [] = Nothing - chunk ls = case break null ls of - (r, rs) -> Just (unlines r, dropWhile null rs) - --- ----------------------------------------------------------------------------- --- Pretty-printing - -showBuildReport :: BuildReport -> String -showBuildReport = showFields fieldDescrs - --- ----------------------------------------------------------------------------- --- Description of the fields, for parsing/printing - -fieldDescrs :: [FieldDescr BuildReport] -fieldDescrs = - [ simpleField "package" disp parse - package (\v r -> r { package = v }) - , simpleField "os" disp parse - os (\v r -> r { os = v }) - , simpleField "arch" disp parse - arch (\v r -> r { arch = v }) - , simpleField "compiler" disp parse - compiler (\v r -> r { compiler = v }) - , simpleField "client" disp parse - client (\v r -> r { client = v }) - , listField "flags" dispFlag parseFlag - flagAssignment (\v r -> r { flagAssignment = v }) - , listField "dependencies" disp parse - dependencies (\v r -> r { dependencies = v }) - , simpleField "install-outcome" disp parse - installOutcome (\v r -> r { installOutcome = v }) - , simpleField "docs-outcome" disp parse - docsOutcome (\v r -> r { docsOutcome = v }) - , simpleField "tests-outcome" disp parse - testsOutcome (\v r -> r { testsOutcome = v }) - ] - -dispFlag :: (FlagName, Bool) -> Disp.Doc -dispFlag (FlagName name, True) = Disp.text name -dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name - -parseFlag :: Parse.ReadP r (FlagName, Bool) -parseFlag = do - value <- Parse.option True (Parse.char '-' >> return False) - name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - return (FlagName name, value) - -instance Text InstallOutcome where - disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> disp pkgid - disp DownloadFailed = Disp.text "DownloadFailed" - disp UnpackFailed = Disp.text "UnpackFailed" - disp SetupFailed = Disp.text "SetupFailed" - disp ConfigureFailed = Disp.text "ConfigureFailed" - disp BuildFailed = Disp.text "BuildFailed" - disp InstallFailed = Disp.text "InstallFailed" - disp InstallOk = Disp.text "InstallOk" - - parse = do - name <- Parse.munch1 Char.isAlphaNum - case name of - "DependencyFailed" -> do Parse.skipSpaces - pkgid <- parse - return (DependencyFailed pkgid) - "DownloadFailed" -> return DownloadFailed - "UnpackFailed" -> return UnpackFailed - "SetupFailed" -> return SetupFailed - "ConfigureFailed" -> return ConfigureFailed - "BuildFailed" -> return BuildFailed - "InstallFailed" -> return InstallFailed - "InstallOk" -> return InstallOk - _ -> Parse.pfail - -instance Text Outcome where - disp NotTried = Disp.text "NotTried" - disp Failed = Disp.text "Failed" - disp Ok = Disp.text "Ok" - parse = do - name <- Parse.munch1 Char.isAlpha - case name of - "NotTried" -> return NotTried - "Failed" -> return Failed - "Ok" -> return Ok - _ -> Parse.pfail - --- ------------------------------------------------------------ --- * InstallPlan support --- ------------------------------------------------------------ - -writeInstallPlanBuildReports :: InstallPlan BuildResult -> IO () -writeInstallPlanBuildReports = writeBuildReports . installPlanBuildReports - -installPlanBuildReports :: InstallPlan BuildResult -> [(BuildReport, Repo)] -installPlanBuildReports plan = catMaybes - . map (planPackageBuildReport os' arch' comp) - . InstallPlan.toList - $ plan - where os' = InstallPlan.planOS plan - arch' = InstallPlan.planArch plan - comp = InstallPlan.planCompiler plan - -planPackageBuildReport :: OS -> Arch -> CompilerId - -> InstallPlan.PlanPackage BuildResult - -> Maybe (BuildReport, Repo) -planPackageBuildReport os' arch' comp planPackage = case planPackage of - - InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage { - packageSource = RepoTarballPackage repo }) _ _) - -> Just $ (buildReport os' arch' comp pkg BR.BuildOk, repo) - - InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage { - packageSource = RepoTarballPackage repo }) _ _) result - -> Just $ (buildReport os' arch' comp pkg result, repo) - - _ -> Nothing diff --git a/Hackage/Setup.hs b/Hackage/Setup.hs deleted file mode 100644 --- a/Hackage/Setup.hs +++ /dev/null @@ -1,370 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Setup --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Hackage.Setup - ( globalCommand, Cabal.GlobalFlags(..) - , configureCommand, filterConfigureFlags - , installCommand, InstallFlags(..) - , listCommand, ListFlags(..) - , updateCommand - , upgradeCommand - , infoCommand - , fetchCommand - , checkCommand - , uploadCommand, UploadFlags(..) - - , parsePackageArgs - ) where - -import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Simple.Command -import qualified Distribution.Simple.Setup as Cabal - (GlobalFlags(..), {-emptyGlobalFlags,-} globalCommand, - ConfigFlags(..), {-emptyConfigFlags,-} configureCommand, -{- CopyFlags(..), emptyCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, installCommand, - HaddockFlags(..), emptyHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, buildCommand, - CleanFlags(..), emptyCleanFlags, cleanCommand, - PFEFlags(..), emptyPFEFlags, programaticaCommand, - MakefileFlags(..), emptyMakefileFlags, makefileCommand, - RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand, - SDistFlags(..), emptySDistFlags, sdistCommand, - testCommand-}) -import Distribution.Simple.Setup - ( Flag(..), toFlag, flagToList, trueArg, optionVerbosity ) -import Distribution.Version - ( Version(Version) ) -import Distribution.Package - ( Dependency ) -import Distribution.Text - ( Text(parse), display ) -import Distribution.ReadE - ( readP_to_E ) -import Distribution.Verbosity (Verbosity, normal) - -import Hackage.Types - ( Username(..), Password(..) ) -import Hackage.ParseUtils (readPToMaybe, parseDependencyOrPackageId) - -import Data.Monoid (Monoid(..)) - -globalCommand :: CommandUI Cabal.GlobalFlags -globalCommand = Cabal.globalCommand { - commandDescription = Just $ \pname -> - "Typical step for installing Cabal packages:\n" - ++ " " ++ pname ++ " install [PACKAGES]\n" - ++ "\nOccasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n" - ++ "\nFor more information about a command, try '" - ++ pname ++ " COMMAND --help'." - ++ "\nThis program is the command line interface to the Haskell Cabal Infrastructure." - ++ "\nSee http://www.haskell.org/cabal/ for more information.\n" - } - -configureCommand :: CommandUI Cabal.ConfigFlags -configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { - commandDefaultFlags = mempty - } - -filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags -filterConfigureFlags flags cabalLibVersion - | cabalLibVersion >= Version [1,3,10] [] = flags - -- older Cabal does not grok the constraints flag: - | otherwise = flags { Cabal.configConstraints = [] } - - -fetchCommand :: CommandUI (Flag Verbosity) -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation or study.", - commandDescription = Nothing, - commandUsage = usagePackages "fetch", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -updateCommand :: CommandUI (Flag Verbosity) -updateCommand = CommandUI { - commandName = "update", - commandSynopsis = "Updates list of known packages", - commandDescription = Nothing, - commandUsage = usagePackages "update", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -upgradeCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags) -upgradeCommand = configureCommand { - commandName = "upgrade", - commandSynopsis = "Upgrades installed packages to the latest available version", - commandDescription = Nothing, - commandUsage = usagePackages "upgrade", - commandDefaultFlags = (mempty, defaultInstallFlags), - commandOptions = \showOrParseArgs -> - liftOptionsFst (commandOptions configureCommand showOrParseArgs) - ++ liftOptionsSnd [optionDryRun] - } - -{- -cleanCommand :: CommandUI () -cleanCommand = makeCommand name shortDesc longDesc emptyFlags options - where - name = "clean" - shortDesc = "Removes downloaded files" - longDesc = Nothing - emptyFlags = () - options _ = [] --} - -infoCommand :: CommandUI (Flag Verbosity) -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Emit some info about dependency resolution", - commandDescription = Nothing, - commandUsage = usagePackages "info", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -checkCommand :: CommandUI (Flag Verbosity) -checkCommand = CommandUI { - commandName = "check", - commandSynopsis = "Check the package for common mistakes", - commandDescription = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", - commandDefaultFlags = mempty, - commandOptions = mempty - } - --- ------------------------------------------------------------ --- * List flags --- ------------------------------------------------------------ - -data ListFlags = ListFlags { - listInstalled :: Flag Bool, - listSimpleOutput :: Flag Bool, - listVerbosity :: Flag Verbosity - } - -defaultListFlags :: ListFlags -defaultListFlags = ListFlags { - listInstalled = Flag False, - listSimpleOutput = Flag False, - listVerbosity = toFlag normal - } - -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List available packages on the server (cached).", - commandDescription = Nothing, - commandUsage = usagePackages "list", - commandDefaultFlags = defaultListFlags, - commandOptions = \_ -> [ - optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) - - , option [] ["installed"] - "Only print installed packages" - listInstalled (\v flags -> flags { listInstalled = v }) - trueArg - - , option [] ["simple-output"] - "Print in a easy-to-parse format" - listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) - trueArg - - ] - } - -instance Monoid ListFlags where - mempty = defaultListFlags - mappend a b = ListFlags { - listInstalled = combine listInstalled, - listSimpleOutput = combine listSimpleOutput, - listVerbosity = combine listVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Install takes the same flags as configure along with a few extras. --- -data InstallFlags = InstallFlags { - installDryRun :: Flag Bool, - installOnly :: Flag Bool, - installRootCmd :: Flag String, - installCabalVersion :: Flag Version - } - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDryRun = Flag False, - installOnly = Flag False, - installRootCmd = mempty, - installCabalVersion = mempty - } - -installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags) -installCommand = configureCommand { - commandName = "install", - commandSynopsis = "Installs a list of packages.", - commandUsage = usagePackages "install", - commandDefaultFlags = (mempty, defaultInstallFlags), - commandOptions = \showOrParseArgs -> - liftOptionsFst (commandOptions configureCommand showOrParseArgs) - ++ liftOptionsSnd - (optionDryRun - :optionRootCmd - :optionCabalVersion - :case showOrParseArgs of -- TODO: remove when "cabal install" avoids - ParseArgs -> [optionOnly] -- reconfiguring/building with dep. analysis - _ -> []) -- It's used by --root-cmd. - - } - -optionDryRun :: OptionField InstallFlags -optionDryRun = - option [] ["dry-run"] - "Do not install anything, only print what would be installed." - installDryRun (\v flags -> flags { installDryRun = v }) - trueArg - -optionOnly :: OptionField InstallFlags -optionOnly = - option [] ["only"] - "Only installs the package in the current directory." - installOnly (\v flags -> flags { installOnly = v }) - trueArg - -optionRootCmd :: OptionField InstallFlags -optionRootCmd = - option [] ["root-cmd"] - "Command used to gain root privileges, when installing with --global." - installRootCmd (\v flags -> flags { installRootCmd = v }) - (reqArg' "COMMAND" toFlag flagToList) - -optionCabalVersion :: OptionField InstallFlags -optionCabalVersion = - option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - installCabalVersion (\v flags -> flags { installCabalVersion = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) - (fmap toFlag parse)) - (map display . flagToList)) - -instance Monoid InstallFlags where - mempty = defaultInstallFlags - mappend a b = InstallFlags { - installDryRun = combine installDryRun, - installOnly = combine installOnly, - installRootCmd = combine installRootCmd, - installCabalVersion = combine installCabalVersion - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Upload flags --- ------------------------------------------------------------ - -data UploadFlags = UploadFlags { - uploadCheck :: Flag Bool, - uploadUsername :: Flag Username, - uploadPassword :: Flag Password, - uploadVerbosity :: Flag Verbosity - } - -defaultUploadFlags :: UploadFlags -defaultUploadFlags = UploadFlags { - uploadCheck = toFlag False, - uploadUsername = mempty, - uploadPassword = mempty, - uploadVerbosity = toFlag normal - } - -uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages to Hackage", - commandDescription = Just $ \_ -> - "You can store your Hackage login in " ++ "FIXME: configFile" - ++ "\nusing the format (\"username\",\"password\").\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" - ++ "Flags for upload:", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) - - ,option ['c'] ["check"] - "Do not upload, just do QA checks." - uploadCheck (\v flags -> flags { uploadCheck = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - ] - } - -instance Monoid UploadFlags where - mempty = UploadFlags { - uploadCheck = mempty, - uploadUsername = mempty, - uploadPassword = mempty, - uploadVerbosity = mempty - } - mappend a b = UploadFlags { - uploadCheck = combine uploadCheck, - uploadUsername = combine uploadUsername, - uploadPassword = combine uploadPassword, - uploadVerbosity = combine uploadVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -liftOptionsFst :: [OptionField a] -> [OptionField (a,b)] -liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b))) - -liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)] -liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b))) - -usagePackages :: String -> String -> String -usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" - ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" - ++ "Flags for " ++ name ++ ":" - ---TODO: do we want to allow per-package flags? -parsePackageArgs :: [String] -> Either String [Dependency] -parsePackageArgs = parsePkgArgs [] - where - parsePkgArgs ds [] = Right (reverse ds) - parsePkgArgs ds (arg:args) = - case readPToMaybe parseDependencyOrPackageId arg of - Just dep -> parsePkgArgs (dep:ds) args - Nothing -> Left ("Failed to parse package dependency: " ++ show arg) diff --git a/Hackage/SetupWrapper.hs b/Hackage/SetupWrapper.hs deleted file mode 100644 --- a/Hackage/SetupWrapper.hs +++ /dev/null @@ -1,300 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.SetupWrapper --- Copyright : (c) The University of Glasgow 2006, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Stability : alpha --- Portability : portable --- --- An interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Hackage.SetupWrapper ( - setupWrapper, - SetupScriptOptions(..), - defaultSetupScriptOptions, - ) where - -import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version(..), VersionRange(..), withinRange ) -import Distribution.Package - ( PackageIdentifier(..), packageName, packageVersion, Dependency(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), BuildType(..), readPackageDescription ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.Simple.Configure - ( configCompiler, getInstalledPackages ) -import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler, PackageDB(..) ) -import Distribution.Simple.Program - ( ProgramConfiguration, emptyProgramConfiguration - , rawSystemProgramConf, ghcProgram ) -import Distribution.Simple.BuildPaths - ( defaultDistPref, exeExtension ) -import Distribution.Simple.Command - ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.GHC - ( ghcVerbosityOptions ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Distribution.Simple.Utils - ( die, debug, cabalVersion, defaultPackageDesc, comparing - , rawSystemExit, createDirectoryIfMissingVerbose ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory ( doesFileExist, getModificationTime ) -import System.FilePath ( (), (<.>) ) -import System.IO.Error ( isDoesNotExistError ) -import Control.Monad ( when, unless ) -import Control.Exception ( evaluate ) -import Data.List ( maximumBy ) -import Data.Maybe ( fromMaybe ) -import Data.Monoid ( Monoid(mempty) ) -import Data.Char ( isSpace ) - -data SetupScriptOptions = SetupScriptOptions { - useCabalVersion :: VersionRange, - useCompiler :: Maybe Compiler, - usePackageIndex :: Maybe (PackageIndex InstalledPackageInfo), - useProgramConfig :: ProgramConfiguration, - useDistPref :: FilePath - } - -defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = AnyVersion, - useCompiler = Nothing, - usePackageIndex = Nothing, - useProgramConfig = emptyProgramConfiguration, - useDistPref = defaultDistPref - } - -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -> [String] - -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do - pkg <- maybe getPkg return mpkg - let setupMethod = determineSetupMethod options' buildType' - options' = options { - useCabalVersion = IntersectVersionRanges - (useCabalVersion options) - (descCabalVersion pkg) - } - buildType' = fromMaybe Custom (buildType pkg) - mkArgs cabalLibVersion = commandName cmd - : commandShowOptions cmd (flags cabalLibVersion) - ++ extraArgs - setupMethod verbosity pkg buildType' mkArgs - where - getPkg = defaultPackageDesc verbosity - >>= readPackageDescription verbosity - >>= return . packageDescription - --- | Decide if we're going to be able to do a direct internal call to the --- entry point in the Cabal library or if we're going to have to compile --- and execute an external Setup.hs script. --- -determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod -determineSetupMethod options buildType' - | buildType' == Custom = externalSetupMethod options - | cabalVersion `withinRange` - useCabalVersion options = internalSetupMethod - | otherwise = externalSetupMethod options - -type SetupMethod = Verbosity -> PackageDescription -> BuildType - -> (Version -> [String]) -> IO () - --- ------------------------------------------------------------ --- * Internal SetupMethod --- ------------------------------------------------------------ - -internalSetupMethod :: SetupMethod -internalSetupMethod verbosity _ bt mkargs = do - let args = mkargs cabalVersion - debug verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Custom = error "buildTypeAction Custom" -buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" - --- ------------------------------------------------------------ --- * External SetupMethod --- ------------------------------------------------------------ - -externalSetupMethod :: SetupScriptOptions -> SetupMethod -externalSetupMethod options verbosity pkg bt mkargs = do - debug verbosity $ "Using external setup method with build-type " ++ show bt - createDirectoryIfMissingVerbose verbosity True setupDir - (cabalLibVersion, options') <- cabalLibVersionToUse - 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) - - where - setupDir = useDistPref options "setup" - setupVersionFile = setupDir "setup" <.> "version" - setupProgFile = setupDir "setup" <.> exeExtension - - cabalLibVersionToUse :: IO (Version, SetupScriptOptions) - cabalLibVersionToUse = do - savedVersion <- savedCabalVersion - case savedVersion of - Just version | version `withinRange` useCabalVersion options - -> return (version, options) - _ -> do (comp, conf, options') <- configureCompiler options - version <- installedCabalVersion options comp conf - writeFile setupVersionFile (show version ++ "\n") - return (version, options') - - savedCabalVersion = do - versionString <- readFile setupVersionFile `catch` \_ -> return "" - case reads versionString of - [(version,s)] | all isSpace s -> return (Just version) - _ -> return Nothing - - installedCabalVersion :: SetupScriptOptions -> Compiler - -> ProgramConfiguration -> IO Version - installedCabalVersion _ _ _ | packageName pkg == "Cabal" = - return (packageVersion pkg) - installedCabalVersion options' comp conf = do - index <- case usePackageIndex options' of - Just index -> return index - Nothing -> fromMaybe mempty - `fmap` getInstalledPackages verbosity comp UserPackageDB conf - -- user packages are *allowed* here, no portability problem - - let cabalDep = Dependency "Cabal" (useCabalVersion options) - case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package requires Cabal library version " - ++ display (useCabalVersion options) - ++ " but no suitable version is installed." - pkgs -> return $ bestVersion (map packageVersion pkgs) - where - bestVersion = maximumBy (comparing preference) - preference version = (sameVersion, sameMajorVersion - ,stableVersion, latestVersion) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionBranch - stableVersion = case versionBranch version of - (_:x:_) -> even x - _ -> False - latestVersion = version - - configureCompiler :: SetupScriptOptions - -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) - configureCompiler options' = do - (comp, conf) <- case useCompiler options' of - Just comp -> return (comp, useProgramConfig options') - Nothing -> configCompiler (Just GHC) Nothing Nothing - (useProgramConfig options') verbosity - return (comp, conf, options' { useCompiler = Just comp, - useProgramConfig = conf }) - - -- | Decide which Setup.hs script to use, creating it if necessary. - -- - updateSetupScript :: Version -> BuildType -> IO FilePath - updateSetupScript _ Custom = do - useHs <- doesFileExist "Setup.hs" - useLhs <- doesFileExist "Setup.lhs" - unless (useHs || useLhs) $ die - "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." - return (if useHs then "Setup.hs" else "Setup.lhs") - - updateSetupScript cabalLibVersion _ = do - rewriteFile setupHs (buildTypeScript cabalLibVersion) - return setupHs - where - setupHs = setupDir "setup" <.> "hs" - - buildTypeScript :: Version -> String - buildTypeScript cabalLibVersion = case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure -> "import Distribution.Simple; main = defaultMainWithHooks " - ++ if cabalLibVersion >= Version [1,3,10] [] - then "autoconfUserHooks\n" - else "defaultUserHooks\n" - Make -> "import Distribution.Make; main = defaultMain\n" - Custom -> error "buildTypeScript Custom" - UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" - - -- | 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 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' - rawSystemProgramConf verbosity ghcProgram conf $ - ghcVerbosityOptions verbosity - ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir] - ++ if packageName pkg == "Cabal" - then ["-i", "-i."] - else ["-package", display cabalPkgid ] - where cabalPkgid = PackageIdentifier "Cabal" cabalLibVersion - - invokeSetupScript :: [String] -> IO () - invokeSetupScript args = rawSystemExit verbosity setupProgFile args - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = - flip catch mightNotExist $ do - existingContent <- readFile path - evaluate (length existingContent) - unless (existingContent == newContent) $ - writeFile path newContent - where - mightNotExist e | isDoesNotExistError e = writeFile path newContent - | otherwise = ioError e diff --git a/Hackage/SrcDist.hs b/Hackage/SrcDist.hs deleted file mode 100644 --- a/Hackage/SrcDist.hs +++ /dev/null @@ -1,80 +0,0 @@ --- Implements the \"@.\/cabal sdist@\" command, which creates a source --- distribution for this package. That is, packs up the source code --- into a tarball, making use of the corresponding Cabal module. -module Hackage.SrcDist ( - sdist - ) where -import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree, prepareSnapshotTree ) -import Hackage.Tar (createTarGzFile) - -import Distribution.Package - ( Package(..) ) -import Distribution.PackageDescription - ( PackageDescription, readPackageDescription ) -import Distribution.Simple.Utils - ( withTempDirectory , defaultPackageDesc - , die, warn, notice, setupMessage ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.PreProcess (knownSuffixHandlers) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Configure(maybeGetPersistBuildConfig) -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.Text - ( display ) - -import System.Time (getClockTime, toCalendarTime) -import System.FilePath ((), (<.>)) -import System.Directory (doesDirectoryExist) -import Control.Monad (when) -import Data.Maybe (isNothing) - --- |Create a source distribution. -sdist :: SDistFlags -> IO () -sdist flags = do - pkg <- return . flattenPackageDescription - =<< readPackageDescription verbosity - =<< defaultPackageDesc verbosity - mb_lbi <- maybeGetPersistBuildConfig distPref - let tmpDir = srcPref distPref - - -- do some QA - printPackageProblems verbosity pkg - - exists <- doesDirectoryExist tmpDir - when exists $ - die $ "Source distribution already in place. please move or remove: " - ++ tmpDir - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - withTempDirectory verbosity tmpDir $ do - - setupMessage verbosity "Building source dist for" (packageId pkg) - if snapshot - then getClockTime >>= toCalendarTime - >>= prepareSnapshotTree verbosity pkg mb_lbi - distPref tmpDir knownSuffixHandlers - else prepareTree verbosity pkg mb_lbi - distPref tmpDir knownSuffixHandlers - targzFile <- createArchive verbosity pkg tmpDir distPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - distPref = fromFlag (sDistDistPref flags) - --- |Create an archive from a tree of source files, and clean up the tree. -createArchive :: Verbosity - -> PackageDescription - -> FilePath - -> FilePath - -> IO FilePath -createArchive _verbosity pkg tmpDir targetPref = do - let tarBallName = display (packageId pkg) - tarBallFilePath = targetPref tarBallName <.> "tar.gz" - createTarGzFile tarBallFilePath tmpDir tarBallName - return tarBallFilePath diff --git a/Hackage/Tar.hs b/Hackage/Tar.hs deleted file mode 100644 --- a/Hackage/Tar.hs +++ /dev/null @@ -1,385 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Check --- Copyright : (c) 2007 Bjorn Bringert, 2008 Andrea Vezzosi --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- Simplistic TAR archive reading and writing --- --- Only handles the file names and file contents, ignores other file metadata. --- ------------------------------------------------------------------------------ -module Hackage.Tar ( - TarHeader(..), - TarFileType(..), - readTarArchive, - extractTarGzFile, - createTarGzFile - ) where - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Data.ByteString.Lazy (ByteString) -import Data.Bits ((.&.),(.|.)) -import Data.Char (ord) -import Data.Int (Int8, Int64) -import Data.List (unfoldr,partition,foldl') -import Data.Maybe (catMaybes) -import Numeric (readOct,showOct) -import System.Directory - ( getDirectoryContents, doesFileExist, doesDirectoryExist - , getModificationTime, createDirectoryIfMissing, copyFile - , Permissions(..), setPermissions, getPermissions ) -import System.Time (ClockTime(..)) -import System.FilePath as FilePath - ( (), isValid, isAbsolute, splitFileName, splitDirectories, makeRelative ) -import qualified System.FilePath.Posix as FilePath.Posix - ( joinPath, pathSeparator ) -import System.Posix.Types (FileMode) -import System.IO - ( Handle, IOMode(ReadMode), openBinaryFile, hFileSize, hClose ) -import System.IO.Unsafe (unsafeInterleaveIO) -import Control.Monad (liftM,when) -import Distribution.Simple.Utils (die) - --- GNU gzip -import qualified Codec.Compression.GZip as GZip - ( decompress, compress ) - --- Or use Ian's gunzip: --- import Codec.Compression.GZip.GUnZip (gunzip) - -data TarHeader = TarHeader { - tarFileName :: FilePath, - tarFileMode :: FileMode, - tarFileType :: TarFileType, - tarLinkTarget :: FilePath - } deriving Show - -data TarFileType = TarNormalFile - | TarHardLink - | TarSymbolicLink - | TarDirectory - | TarOther Char - deriving (Eq,Show) - -readTarArchive :: ByteString -> [(TarHeader,ByteString)] -readTarArchive = catMaybes . unfoldr getTarEntry - -extractTarArchive :: FilePath -> [(TarHeader,ByteString)] -> IO () -extractTarArchive dir tar = extract files >> extract links - where - extract = mapM_ (uncurry (extractEntry dir)) - -- TODO: does this cause a memory leak? - (files, links) = partition (not . isLink . tarFileType . fst) tar - isLink TarHardLink = True - isLink TarSymbolicLink = True - isLink _ = False - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir file = - extractTarArchive dir . readTarArchive . GZip.decompress =<< BS.readFile file - --- --- * Extracting --- - -extractEntry :: FilePath -> TarHeader -> ByteString -> IO () -extractEntry dir hdr cnt - = do path <- relativizePath dir (tarFileName hdr) - let setPerms = setPermissions path (fileModeToPermissions (tarFileMode hdr)) - copyLinked = - let (base, _) = splitFileName path - sourceName = base tarLinkTarget hdr - in copyFile sourceName path - case tarFileType hdr of - TarNormalFile -> BS.writeFile path cnt >> setPerms - TarHardLink -> copyLinked >> setPerms - TarSymbolicLink -> copyLinked - TarDirectory -> createDirectoryIfMissing False path >> setPerms - TarOther _ -> return () -- FIXME: warning? - -relativizePath :: Monad m => FilePath -> FilePath -> m FilePath -relativizePath dir file - | isAbsolute file = fail $ "Absolute file name in TAR archive: " ++ show file - | not (isValid file) = fail $ "Invalid file name in TAR archive: " ++ show file - | otherwise = return $ dir file - -fileModeToPermissions :: FileMode -> Permissions -fileModeToPermissions m = - Permissions { - readable = m .&. ownerReadMode /= 0, - writable = m .&. ownerWriteMode /= 0, - executable = m .&. ownerExecuteMode /= 0, - searchable = m .&. ownerExecuteMode /= 0 - } - -ownerReadMode :: FileMode -ownerReadMode = 0o000400 - -ownerWriteMode :: FileMode -ownerWriteMode = 0o000200 - -ownerExecuteMode :: FileMode -ownerExecuteMode = 0o000100 - --- --- * Reading --- - -getTarEntry :: ByteString -> Maybe (Maybe (TarHeader,ByteString), ByteString) -getTarEntry bs | endBlock = Nothing - | BS.length hdr < 512 = error "Truncated TAR archive." - | not (checkChkSum hdr chkSum) = error "TAR checksum error." - | otherwise = Just (Just (info, cnt), bs''') - - where (hdr,bs') = BS.splitAt 512 bs - - endBlock = getByte 0 hdr == '\0' - - fileSuffix = getString 0 100 hdr - mode = getOct 100 8 hdr - chkSum = getOct 148 8 hdr - typ = getByte 156 hdr - size = getOct 124 12 hdr - linkTarget = getString 157 100 hdr - filePrefix = getString 345 155 hdr - - padding = (512 - size) `mod` 512 - (cnt,bs'') = BS.splitAt size bs' - bs''' = BS.drop padding bs'' - - fileType = case typ of - '\0'-> TarNormalFile - '0' -> TarNormalFile - '1' -> TarHardLink - '2' -> TarSymbolicLink - '5' -> TarDirectory - c -> TarOther c - - path = filePrefix ++ fileSuffix - info = TarHeader { tarFileName = path, - tarFileMode = mode, - tarFileType = fileType, - tarLinkTarget = linkTarget } - -checkChkSum :: ByteString -> Int -> Bool -checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr' - where - -- replace the checksum with spaces - hdr' = BS.concat [BS.take 148 hdr, BS.Char8.replicate 8 ' ', BS.drop 156 hdr] - -- tar.info says that Sun tar is buggy and - -- calculates the checksum using signed chars - chkSum = BS.Char8.foldl' (\x y -> x + ord y) 0 - signedChkSum = BS.Char8.foldl' (\x y -> x + (ordSigned y)) 0 - -ordSigned :: Char -> Int -ordSigned c = fromIntegral (fromIntegral (ord c) :: Int8) - --- * TAR format primitive input - -getOct :: Integral a => Int64 -> Int64 -> ByteString -> a -getOct off len = parseOct . getString off len - where parseOct "" = 0 - parseOct s = case readOct s of - [(x,_)] -> x - _ -> error $ "Number format error: " ++ show s - -getBytes :: Int64 -> Int64 -> ByteString -> ByteString -getBytes off len = BS.take len . BS.drop off - -getByte :: Int64 -> ByteString -> Char -getByte off bs = BS.Char8.index bs off - -getString :: Int64 -> Int64 -> ByteString -> String -getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len - --- --- * Writing --- - --- | Creates a tar gzipped archive, the paths in the archive will be relative --- to the base directory. --- -createTarGzFile :: FilePath -- ^ Full Tarball path - -> FilePath -- ^ Base directory - -> FilePath -- ^ Directory or file to package, relative to the base dir - -> IO () -createTarGzFile tarFile baseDir sourceDir = do - (entries,hs) <- fmap unzip - . mapM (unsafeInterleaveIO - . (\path -> createTarEntry path - $ makeRelative baseDir path)) - =<< recurseDirectories [baseDir sourceDir] - BS.writeFile tarFile . GZip.compress . entries2Archive $ entries - mapM_ hClose (catMaybes hs) -- TODO: the handles are explicitly closed because of a bug in bytestring-0.9.0.1, - -- once we depend on a later version we can avoid this hack. - -recurseDirectories :: [FilePath] -> IO [FilePath] -recurseDirectories = - liftM concat . mapM (\p -> liftM (p:) $ unsafeInterleaveIO $ descendants p) - where - descendants path = - do d <- doesDirectoryExist path - if d then do cs <- getDirectoryContents path - let cs' = [pathc | c <- cs, includeDir c] - ds <- recurseDirectories cs' - return ds - else return [] - where includeDir "." = False - includeDir ".." = False - includeDir _ = True - -data TarEntry = TarEntry { entryHdr :: TarHeader, entrySize :: Integer, entryModTime :: EpochTime, entryCnt :: ByteString } - --- | Creates an uncompressed archive -entries2Archive :: [TarEntry] -> ByteString -entries2Archive es = BS.concat $ (map putTarEntry es) ++ [BS.replicate (512*2) 0] - --- TODO: It needs to return the handle only because of the hack in createTarGzFile -createTarEntry :: FilePath -- ^ path to find the file - -> FilePath -- ^ path to use for the TarHeader - -> IO (TarEntry,Maybe Handle) -createTarEntry path relpath = - do ftype <- getFileType path - let tarpath = nativePathToTarPath ftype relpath - when (null tarpath || length tarpath > 255) $ - die $ "Path too long: " ++ show tarpath - mode <- getFileMode ftype path - let hdr = TarHeader { - tarFileName = tarpath, - tarFileMode = mode, - tarFileType = ftype, - tarLinkTarget = "" - } - (sz,cnt,mh) <- case ftype of - TarNormalFile -> do h <- openBinaryFile path ReadMode - sz <- hFileSize h - cnt <- BS.hGetContents h - return (sz,cnt,Just h) - _ -> return (0,BS.empty,Nothing) - time <- getModTime path - return $ (TarEntry hdr sz time cnt,mh) - -getFileType :: FilePath -> IO TarFileType -getFileType path = do b <- doesFileExist path - if b then return TarNormalFile - else do b' <- doesDirectoryExist path - if b' then return TarDirectory - else fail $ "tar: Not directory nor regular file: " ++ path - --- We can't be precise because of portability, so we default to rw-r--r-- for normal files --- and rwxr-xr-x for directories and executables. -getFileMode :: TarFileType -> FilePath -> IO FileMode -getFileMode ftype path = do - perms <- getPermissions path - let x = if executable perms || ftype == TarDirectory then 0o000111 else 0 - return $ 0o000644 .|. x - -type EpochTime = Int - -getModTime :: FilePath -> IO EpochTime -getModTime path = - do (TOD s _) <- getModificationTime path - return (fromIntegral s) - -putTarEntry :: TarEntry -> ByteString -putTarEntry TarEntry{entryHdr=hdr,entrySize=size,entryModTime=time,entryCnt=cnt} = - BS.concat - [putTarHeader hdr size time - ,cnt - ,BS.replicate ((- fromIntegral size) `mod` 512) 0 - ] - - -putTarHeader :: TarHeader -> Integer -> EpochTime -> BS.ByteString -putTarHeader hdr filesize modTime = - let block = concat $ (putHeaderNoChkSum hdr filesize modTime) - chkSum = foldl' (\x y -> x + ord y) 0 block - in BS.Char8.pack $ take 148 block ++ - putOct 8 chkSum ++ - drop 156 block - -putHeaderNoChkSum :: TarHeader -> Integer -> EpochTime -> [String] -putHeaderNoChkSum hdr filesize modTime = - let (filePrefix, fileSuffix) = splitLongPath (tarFileName hdr) in - [ putString 100 $ fileSuffix - , putOct 8 $ tarFileMode hdr - , putOct 8 $ zero --tarOwnerID hdr - , putOct 8 $ zero --tarGroupID hdr - , putOct 12 $ filesize --tarFileSize hdr - , putOct 12 $ modTime --epochTimeToSecs $ tarModTime hdr - , fill 8 $ ' ' -- dummy checksum - , putTarFileType $ tarFileType hdr - , putString 100 $ tarLinkTarget hdr -- FIXME: take suffix split at / if too long - , putString 6 $ "ustar" - , putString 2 $ "00" -- no nul byte - , putString 32 $ "" --tarOwnerName hdr - , putString 32 $ "" --tarGroupName hdr - , putOct 8 $ zero --tarDeviceMajor hdr - , putOct 8 $ zero --tarDeviceMinor hdr - , putString 155 $ filePrefix - , fill 12 $ '\NUL' - ] - where zero :: Int - zero = 0 - -putTarFileType :: TarFileType -> String -putTarFileType t = - putChar8 $ case t of - TarNormalFile -> '0' - TarHardLink -> '1' - TarSymbolicLink -> '2' - TarDirectory -> '5' - TarOther c -> c - --- | Convert a native path to a unix\/posix style path --- and for directories add a trailing @\/@. --- -nativePathToTarPath :: TarFileType -> FilePath -> FilePath -nativePathToTarPath ftype = addTrailingSep ftype - . FilePath.Posix.joinPath - . FilePath.splitDirectories - where - addTrailingSep TarDirectory path = path ++ [FilePath.Posix.pathSeparator] - addTrailingSep _ path = path - --- | Takes a sanitized path, i.e. converted to Posix form -splitLongPath :: FilePath -> (String,String) -splitLongPath path = - let (x,y) = splitAt (length path - 101) path - -- 101 since we will always move a separator to the prefix - in if null x - then if null y then err "Empty path." else ("", y) - else case break (==FilePath.Posix.pathSeparator) y of - --TODO: convert this to use FilePath.Posix.splitPath - (_,"") -> err "Can't split path." - (_,_:"") -> err "Can't split path." - (y1,s:y2) | length p > 155 || length y2 > 100 -> err "Can't split path." - | otherwise -> (p,y2) - where p = x ++ y1 ++ [s] - where err e = error $ show path ++ ": " ++ e - --- * TAR format primitive output - -putString :: Int -> String -> String -putString n s = take n s ++ - fill (n - length s) '\NUL' - -putOct :: (Integral a) => Int -> a -> String -putOct n x = let o = take (n-1) $ showOct x "" in - fill (n - length o - 1) '0' ++ - o ++ - putChar8 '\NUL' - -putChar8 :: Char -> String -putChar8 c = [c] - -fill :: Int -> Char -> String -fill n c = replicate n c diff --git a/Hackage/Types.hs b/Hackage/Types.hs deleted file mode 100644 --- a/Hackage/Types.hs +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Types --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files. ------------------------------------------------------------------------------ -module Hackage.Types where - -import Distribution.Package - ( PackageIdentifier(..), Package(..), PackageFixedDeps(..) - , Dependency ) -import Distribution.PackageDescription - ( GenericPackageDescription, FlagAssignment ) - -import Network.URI (URI) -import Control.Exception - ( Exception ) - -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } - --- | A 'ConfiguredPackage' is a not-yet-installed package along with the --- total configuration information. The configuration information is total in --- the sense that it provides all the configuration information and so the --- final configure process will be independent of the environment. --- -data ConfiguredPackage = ConfiguredPackage - AvailablePackage -- package info, including repo - FlagAssignment -- complete flag assignment for the package - [PackageIdentifier] -- set of exact dependencies. These must be - -- consistent with the 'buildDepends' in the - -- 'PackageDescrption' that you'd get by applying - -- the flag assignment. - deriving Show - -instance Package ConfiguredPackage where - packageId (ConfiguredPackage pkg _ _) = packageId pkg - -instance PackageFixedDeps ConfiguredPackage where - depends (ConfiguredPackage _ _ deps) = deps - - --- | We re-use @GenericPackageDescription@ and use the @package-url@ --- field to store the tarball URI. -data AvailablePackage = AvailablePackage { - packageInfoId :: PackageIdentifier, - packageDescription :: GenericPackageDescription, - packageSource :: AvailablePackageSource - } - deriving Show - -instance Package AvailablePackage where packageId = packageInfoId - -data AvailablePackageSource = - - -- | The unpacked package in the current dir - LocalUnpackedPackage - - -- | A package available as a tarball from a remote repository, with a - -- locally cached copy. ie a package available from hackage - | RepoTarballPackage Repo - --- | ScmPackage - deriving Show - ---TODO: --- * generalise local package to any local unpacked package, not just in the --- current dir, ie add a FilePath param --- * add support for darcs and other SCM style remote repos with a local cache - -data RemoteRepo = RemoteRepo { - remoteRepoName :: String, - remoteRepoURI :: URI - } - deriving (Show,Eq) - -data Repo = Repo { - repoRemote :: RemoteRepo, - repoCacheDir :: FilePath - } - deriving (Show,Eq) - -repoName :: Repo -> String -repoName = remoteRepoName . repoRemote - -repoURI :: Repo -> URI -repoURI = remoteRepoURI . repoRemote - -data UnresolvedDependency - = UnresolvedDependency - { dependency :: Dependency - , depFlags :: FlagAssignment - } - deriving (Show) - -data BuildResult = DependentFailed PackageIdentifier - | UnpackFailed Exception - | ConfigureFailed Exception - | BuildFailed Exception - | InstallFailed Exception - | BuildOk diff --git a/Hackage/Update.hs b/Hackage/Update.hs deleted file mode 100644 --- a/Hackage/Update.hs +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Hackage.Update --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Hackage.Update - ( update - ) where - -import Hackage.Types -import Hackage.Fetch - -import Distribution.Simple.Utils (notice) -import Distribution.Verbosity (Verbosity) - -import qualified Data.ByteString.Lazy as BS -import qualified Codec.Compression.GZip as GZip (decompress) -import System.FilePath (dropExtension) - --- | 'update' downloads the package list from all known servers -update :: Verbosity -> [Repo] -> IO () -update verbosity = mapM_ (updateRepo verbosity) - -updateRepo :: Verbosity -> Repo -> IO () -updateRepo verbosity repo = do - notice verbosity $ "Downloading package list from server '" - ++ show (repoURI repo) ++ "'" - indexPath <- downloadIndex verbosity repo - BS.writeFile (dropExtension indexPath) . GZip.decompress - =<< BS.readFile indexPath diff --git a/Hackage/Upload.hs b/Hackage/Upload.hs deleted file mode 100644 --- a/Hackage/Upload.hs +++ /dev/null @@ -1,137 +0,0 @@ --- This is a quick hack for uploading packages to Hackage. --- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload - -module Hackage.Upload (check, upload) where - -import Hackage.Types (Username(..), Password(..)) -import Hackage.HttpUtils (proxy) - -import Distribution.Simple.Utils (debug, notice, warn) -import Distribution.Verbosity (Verbosity) - -import Network.Browser (BrowserAction, browse, request, - Authority(..), addAuthority, - setOutHandler, setErrHandler, setProxy) -import Network.HTTP (Header(..), HeaderName(..), Request(..), - RequestMethod(..), Response(..)) -import Network.URI (URI, parseURI) - -import Data.Char (intToDigit) -import Numeric (showHex) -import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho - ,openBinaryFile, IOMode(ReadMode), hGetContents) -import Control.Exception (bracket) -import System.Random (randomRIO) - - - ---FIXME: how do we find this path for an arbitrary hackage server? --- is it always at some fixed location relative to the server root? -uploadURI :: URI -Just uploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" - -checkURI :: URI -Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" - - -upload :: Verbosity -> Maybe Username -> Maybe Password -> [FilePath] -> IO () -upload verbosity mUsername mPassword paths = do - - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword - 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 - - where - promptUsername :: IO Username - promptUsername = do - putStr "Hackage username: " - hFlush stdout - fmap Username getLine - - promptPassword :: IO Password - promptPassword = do - putStr "Hackage password: " - hFlush stdout - -- save/restore the terminal echoing status - bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap Password getLine - -check :: Verbosity -> [FilePath] -> IO () -check verbosity paths = do - flip mapM_ paths $ \path -> do - notice verbosity $ "Checking " ++ path ++ "... " - handlePackage verbosity checkURI (return ()) path - -handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO () -handlePackage verbosity uri auth path = - do req <- mkRequest uri path - p <- proxy verbosity - debug verbosity $ "\n" ++ show req - (_,resp) <- browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - auth - request req - debug verbosity $ show resp - case rspCode resp of - (2,0,0) -> do notice verbosity "OK" - (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " - ++ map intToDigit [x,y,z] ++ " " - ++ rspReason resp - debug verbosity $ rspBody resp - -mkRequest :: URI -> FilePath -> IO Request -mkRequest uri path = - do pkg <- readBinaryFile path - boundary <- genBoundary - let body = printMultiPart boundary (mkFormData path pkg) - return $ Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), - Header HdrContentLength (show (length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - -readBinaryFile :: FilePath -> IO String -readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents - -genBoundary :: IO String -genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" - -mkFormData :: FilePath -> String -> [BodyPart] -mkFormData path pkg = - -- yes, web browsers are that stupid (re quoting) - [BodyPart [Header hdrContentDisposition ("form-data; name=package; filename=\""++path++"\""), - Header HdrContentType "application/x-gzip"] - pkg] - -hdrContentDisposition :: HeaderName -hdrContentDisposition = HdrCustom "Content-disposition" - --- * Multipart, partly stolen from the cgi package. - -data BodyPart = BodyPart [Header] String - -printMultiPart :: String -> [BodyPart] -> String -printMultiPart boundary xs = - concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf - -printBodyPart :: String -> BodyPart -> String -printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c - -crlf :: String -crlf = "\r\n" diff --git a/Hackage/Utils.hs b/Hackage/Utils.hs deleted file mode 100644 --- a/Hackage/Utils.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Hackage.Utils where - -import Distribution.Package - ( Dependency(..) ) -import Distribution.Text - ( display ) -import Distribution.Simple.Utils (intercalate) - -import Data.List - ( sortBy, groupBy ) -import Control.Monad (guard) -import Control.Exception (Exception, catchJust, ioErrors) -import System.IO.Error (isDoesNotExistError) - -readFileIfExists :: FilePath -> IO (Maybe String) -readFileIfExists path = - catchJust fileNotFoundExceptions - (fmap Just (readFile path)) - (\_ -> return Nothing) - -fileNotFoundExceptions :: Exception -> Maybe IOError -fileNotFoundExceptions e = - ioErrors e >>= \ioe -> guard (isDoesNotExistError ioe) >> return ioe - -showDependencies :: [Dependency] -> String -showDependencies = intercalate ", " . map display - --- | Generic merging utility. For sorted input lists this is a full outer join. --- --- * The result list never contains @(Nothing, Nothing)@. --- -mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] -mergeBy cmp = merge - where - merge [] ys = [ OnlyInRight y | y <- ys] - merge xs [] = [ OnlyInLeft x | x <- xs] - merge (x:xs) (y:ys) = - case x `cmp` y of - GT -> OnlyInRight y : merge (x:xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y:ys) - -data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b - -duplicates :: Ord a => [a] -> [[a]] -duplicates = duplicatesBy compare - -duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] -duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp - where - eq a b = case cmp a b of - EQ -> True - _ -> False - moreThanOne (_:_:_) = True - moreThanOne _ = False diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -13,34 +13,51 @@ module Main where -import Hackage.Setup -import Hackage.Types +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, globalRepos + , ConfigFlags(..), configureCommand + , InstallFlags(..), installCommand, upgradeCommand + , fetchCommand, checkCommand + , updateCommand + , ListFlags(..), listCommand + , UploadFlags(..), uploadCommand + , reportCommand + , parsePackageArgs, configPackageDB' ) +import Distribution.Simple.Setup + ( BuildFlags(..), buildCommand + , HaddockFlags(..), haddockCommand + , HscolourFlags(..), hscolourCommand + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , SDistFlags(..), sdistCommand + , TestFlags(..), testCommand + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) + +import Distribution.Client.Types ( UnresolvedDependency(UnresolvedDependency) ) -import Distribution.Simple.Setup (Flag(..), fromFlag, fromFlagOrDefault, - flagToMaybe,SDistFlags,sdistCommand) -import qualified Distribution.Simple.Setup as Cabal +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig ) +import Distribution.Client.List (list) +import Distribution.Client.Install (install, upgrade) +import Distribution.Client.Update (update) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import Distribution.Client.Upload as Upload (upload, check, report) +import Distribution.Client.SrcDist (sdist) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade + import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Command import Distribution.Simple.Configure (configCompilerAux) import Distribution.Simple.Utils (cabalVersion, die, intercalate) import Distribution.Text ( display ) - -import Hackage.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Hackage.Config (SavedConfig(..), savedConfigToConfigFlags, - defaultConfigFile, loadConfig, configRepos, - configPackageDB) -import Hackage.List (list) -import Hackage.Install (install, upgrade) -import Hackage.Update (update) -import Hackage.Fetch (fetch) -import Hackage.Check as Check (check) ---import Hackage.Clean (clean) -import Hackage.Upload as Upload (upload, check) -import Hackage.SrcDist(sdist) - -import Distribution.Verbosity (Verbosity, normal) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal, intToVerbosity ) import qualified Paths_cabal_install (version) import System.Environment (getArgs, getProgName) @@ -48,6 +65,7 @@ import System.FilePath (splitExtension, takeExtension) import System.Directory (doesFileExist) import Data.List (intersperse) +import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import Control.Monad (unless) @@ -57,19 +75,20 @@ main = getArgs >>= mainWorker mainWorker :: [String] -> IO () -mainWorker args = +mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args +mainWorker args = case commandsRun globalCommand commands args of CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> + CommandReadyToGo (globalflags, commandParse) -> case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion CommandHelp help -> printHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action + CommandReadyToGo action -> action globalflags where printHelp help = getProgName >>= putStr . help @@ -94,29 +113,31 @@ ,uploadCommand `commandAddAction` uploadAction ,checkCommand `commandAddAction` checkAction ,sdistCommand `commandAddAction` sdistAction - ,wrapperAction (Cabal.buildCommand defaultProgramConfiguration) - Cabal.buildVerbosity Cabal.buildDistPref - ,wrapperAction Cabal.copyCommand - Cabal.copyVerbosity Cabal.copyDistPref - ,wrapperAction Cabal.haddockCommand - Cabal.haddockVerbosity Cabal.haddockDistPref - ,wrapperAction Cabal.cleanCommand - Cabal.cleanVerbosity Cabal.cleanDistPref - ,wrapperAction Cabal.hscolourCommand - Cabal.hscolourVerbosity Cabal.hscolourDistPref - ,wrapperAction Cabal.registerCommand - Cabal.regVerbosity Cabal.regDistPref - ,wrapperAction Cabal.testCommand - Cabal.testVerbosity Cabal.testDistPref + ,reportCommand `commandAddAction` reportAction + ,wrapperAction (buildCommand defaultProgramConfiguration) + buildVerbosity buildDistPref + ,wrapperAction copyCommand + copyVerbosity copyDistPref + ,wrapperAction haddockCommand + haddockVerbosity haddockDistPref + ,wrapperAction cleanCommand + cleanVerbosity cleanDistPref + ,wrapperAction hscolourCommand + hscolourVerbosity hscolourDistPref + ,wrapperAction registerCommand + regVerbosity regDistPref + ,wrapperAction testCommand + testVerbosity testDistPref ] wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) -> (flags -> Flag String) - -> Command (IO ()) + -> Command (GlobalFlags -> IO ()) wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command $ \flags extraArgs -> do + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do let verbosity = fromFlagOrDefault normal (verbosityFlag flags) setupScriptOptions = defaultSetupScriptOptions { useDistPref = fromFlagOrDefault @@ -126,113 +147,108 @@ setupWrapper verbosity setupScriptOptions Nothing command (const flags) extraArgs -configureAction :: Cabal.ConfigFlags -> [String] -> IO () -configureAction flags extraArgs = do - configFile <- defaultConfigFile --FIXME - let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity flags) - config <- loadConfig verbosity configFile - let flags' = savedConfigToConfigFlags (Cabal.configUserInstall flags) config - `mappend` flags +configureAction :: ConfigFlags -> [String] -> GlobalFlags -> IO () +configureAction flags extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity flags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall flags) + let flags' = savedConfigureFlags config `mappend` flags (comp, conf) <- configCompilerAux flags' let setupScriptOptions = defaultSetupScriptOptions { useCompiler = Just comp, useProgramConfig = conf, useDistPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) - (Cabal.configDistPref flags) + (configDistPref flags) } setupWrapper verbosity setupScriptOptions Nothing configureCommand (const flags') extraArgs -installAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO () -installAction (cflags,iflags) _ - | Cabal.fromFlag (installOnly iflags) - = let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags) +installAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO () +installAction (cflags,iflags) _ _globalFlags + | fromFlagOrDefault False (installOnly iflags) + = let verbosity = fromFlagOrDefault normal (configVerbosity cflags) in setupWrapper verbosity defaultSetupScriptOptions Nothing - Cabal.installCommand mempty [] + installCommand mempty [] -installAction (cflags,iflags) extraArgs = do +installAction (cflags,iflags) extraArgs globalFlags = do pkgs <- either die return (parsePackageArgs extraArgs) - configFile <- defaultConfigFile --FIXME - let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags) - config <- loadConfig verbosity configFile - let cflags' = savedConfigToConfigFlags (Cabal.configUserInstall cflags) config - `mappend` cflags + let verbosity = fromFlagOrDefault normal (configVerbosity cflags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall cflags) + let cflags' = savedConfigureFlags config `mappend` cflags + iflags' = savedInstallFlags config `mappend` iflags (comp, conf) <- configCompilerAux cflags' install verbosity - (configPackageDB cflags') (configRepos config) - comp conf cflags' iflags - [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags') + (configPackageDB' cflags') (globalRepos (savedGlobalFlags config)) + comp conf cflags' iflags' + [ UnresolvedDependency pkg (configConfigurationsFlags cflags') | pkg <- pkgs ] -listAction :: ListFlags -> [String] -> IO () -listAction listFlags extraArgs = do - configFile <- defaultConfigFile --FIXME +listAction :: ListFlags -> [String] -> GlobalFlags -> IO () +listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) - config <- loadConfig verbosity configFile - let flags = savedConfigToConfigFlags NoFlag config + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let flags = savedConfigureFlags config (comp, conf) <- configCompilerAux flags list verbosity - (configPackageDB flags) - (configRepos config) + (configPackageDB' flags) + (globalRepos (savedGlobalFlags config)) comp conf listFlags extraArgs -updateAction :: Flag Verbosity -> [String] -> IO () -updateAction verbosityFlag extraArgs = do +updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +updateAction verbosityFlag extraArgs globalFlags = do unless (null extraArgs) $ do die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - configFile <- defaultConfigFile --FIXME let verbosity = fromFlag verbosityFlag - config <- loadConfig verbosity configFile - update verbosity (configRepos config) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + update verbosity (globalRepos (savedGlobalFlags config)) -upgradeAction :: (Cabal.ConfigFlags, InstallFlags) -> [String] -> IO () -upgradeAction (cflags,iflags) extraArgs = do +upgradeAction :: (ConfigFlags, InstallFlags) -> [String] -> GlobalFlags -> IO () +upgradeAction (cflags,iflags) extraArgs globalFlags = do pkgs <- either die return (parsePackageArgs extraArgs) - configFile <- defaultConfigFile --FIXME - let verbosity = fromFlagOrDefault normal (Cabal.configVerbosity cflags) - config <- loadConfig verbosity configFile - let cflags' = savedConfigToConfigFlags (Cabal.configUserInstall cflags) config - `mappend` cflags + let verbosity = fromFlagOrDefault normal (configVerbosity cflags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall cflags) + let cflags' = savedConfigureFlags config `mappend` cflags + iflags' = savedInstallFlags config `mappend` iflags (comp, conf) <- configCompilerAux cflags' upgrade verbosity - (configPackageDB cflags') (configRepos config) - comp conf cflags' iflags - [ UnresolvedDependency pkg (Cabal.configConfigurationsFlags cflags') + (configPackageDB' cflags') (globalRepos (savedGlobalFlags config)) + comp conf cflags' iflags' + [ UnresolvedDependency pkg (configConfigurationsFlags cflags') | pkg <- pkgs ] -fetchAction :: Flag Verbosity -> [String] -> IO () -fetchAction verbosityFlag extraArgs = do +fetchAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +fetchAction verbosityFlag extraArgs globalFlags = do pkgs <- either die return (parsePackageArgs extraArgs) - configFile <- defaultConfigFile --FIXME let verbosity = fromFlag verbosityFlag - config <- loadConfig verbosity configFile - let flags = savedConfigToConfigFlags NoFlag config + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let flags = savedConfigureFlags config (comp, conf) <- configCompilerAux flags fetch verbosity - (configPackageDB flags) (configRepos config) + (configPackageDB' flags) (globalRepos (savedGlobalFlags config)) comp conf [ UnresolvedDependency pkg [] --TODO: flags? | pkg <- pkgs ] -uploadAction :: UploadFlags -> [String] -> IO () -uploadAction flags extraArgs = do - configFile <- defaultConfigFile --FIXME - let verbosity = fromFlag (uploadVerbosity flags) - config <- loadConfig verbosity configFile +uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () +uploadAction uploadFlags extraArgs globalFlags = do + let verbosity = fromFlag (uploadVerbosity uploadFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags -- FIXME: check that the .tar.gz files exist and report friendly error message if not let tarfiles = extraArgs checkTarFiles tarfiles - if fromFlag (uploadCheck flags) + if fromFlag (uploadCheck uploadFlags') then Upload.check verbosity tarfiles - else upload verbosity - (flagToMaybe $ configUploadUsername config - `mappend` uploadUsername flags) - (flagToMaybe $ configUploadPassword config - `mappend` uploadPassword flags) + else upload verbosity + (globalRepos (savedGlobalFlags config)) + (flagToMaybe $ uploadUsername uploadFlags') + (flagToMaybe $ uploadPassword uploadFlags') tarfiles where checkTarFiles tarfiles @@ -251,16 +267,36 @@ (file', ".gz") -> takeExtension file' == ".tar" _ -> False -checkAction :: Flag Verbosity -> [String] -> IO () -checkAction verbosityFlag extraArgs = do +checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +checkAction verbosityFlag extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction sflags extraArgs = do +sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO () +sdistAction sflags extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs sdist sflags + +reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +reportAction verbosityFlag extraArgs globalFlags = do + unless (null extraArgs) $ do + die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + + let verbosity = fromFlag verbosityFlag + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + + Upload.report verbosity (globalRepos (savedGlobalFlags config)) + +win32SelfUpgradeAction :: [String] -> IO () +win32SelfUpgradeAction (pid:path:rest) = + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path + where + verbosity = case rest of + (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9'] + -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) + _ -> Verbosity.normal +win32SelfUpgradeAction _ = return () diff --git a/bootstrap.sh b/bootstrap.sh new file mode 100644 --- /dev/null +++ b/bootstrap.sh @@ -0,0 +1,40 @@ +#!/bin/sh + +# A script to bootstrap cabal-install. + +# It works by downloading and installing the Cabal, zlib and +# HTTP packages. It then installs cabal-install itself. +# It expects to be run inside the cabal-install directory. + +CABAL_VER="1.4.0.2" +HTTP_VER="3001.0.4" +ZLIB_VER="0.4.0.4" + +HACKAGE_URL="http://hackage.haskell.org/packages/archive" +CABAL_URL=${HACKAGE_URL}/Cabal/${CABAL_VER}/Cabal-${CABAL_VER}.tar.gz +HTTP_URL=${HACKAGE_URL}/HTTP/${HTTP_VER}/HTTP-${HTTP_VER}.tar.gz +ZLIB_URL=${HACKAGE_URL}/zlib/${ZLIB_VER}/zlib-${ZLIB_VER}.tar.gz + +wget ${CABAL_URL} ${HTTP_URL} ${ZLIB_URL} + +tar -zxf Cabal-${CABAL_VER}.tar.gz +pushd Cabal-${CABAL_VER} +ghc --make Setup +./Setup configure --user && ./Setup build && ./Setup install +popd + +tar -zxf HTTP-${HTTP_VER}.tar.gz +pushd HTTP-${HTTP_VER} +runghc Setup configure --user && runghc Setup build && runghc Setup install +popd + +tar -zxf zlib-${ZLIB_VER}.tar.gz +pushd zlib-${ZLIB_VER} +runghc Setup configure --user && runghc Setup build && runghc Setup install +popd + +runghc Setup configure --user && runghc Setup build && runghc Setup install + +echo +echo "If all went well then 'cabal' is in $HOME/.cabal/bin/" +echo "You may want to add this dir to your PATH" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Name: cabal-install -Version: 0.5.1 +Version: 0.5.2 Synopsis: The command-line interface for Cabal and Hackage. -Description: +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. @@ -9,19 +9,19 @@ License-File: LICENSE Author: Lemmih Paolo Martini - Bjorn Bringert - Isaac Potoczny-Jones - Duncan Coutts + Bjorn Bringert + Isaac Potoczny-Jones + Duncan Coutts Maintainer: cabal-devel@haskell.org Copyright: 2005 Lemmih 2006 Paolo Martini - 2007 Bjorn Bringert - 2007 Isaac Potoczny-Jones - 2008 Duncan Coutts + 2007 Bjorn Bringert + 2007 Isaac Potoczny-Jones + 2008 Duncan Coutts Stability: Experimental Category: Distribution Build-type: Simple -Extra-Source-Files: README bash-completion/cabal +Extra-Source-Files: README bash-completion/cabal bootstrap.sh Cabal-Version: >= 1.2 flag old-base @@ -36,33 +36,33 @@ -- although it is expensive, we want to catch problems early: Ghc-Options: -Wall -fno-ignore-asserts Other-Modules: - Hackage.Check --- Hackage.Clean - Hackage.Config - Hackage.Dependency - Hackage.Dependency.Bogus - Hackage.Dependency.Naive - Hackage.Dependency.TopDown - Hackage.Dependency.TopDown.Constraints - Hackage.Dependency.TopDown.Types - Hackage.Dependency.Types - Hackage.Fetch - Hackage.HttpUtils - Hackage.IndexUtils --- Hackage.Info - Hackage.Install - Hackage.InstallPlan - Hackage.List - Hackage.ParseUtils - Hackage.Reporting - Hackage.Setup - Hackage.SetupWrapper - Hackage.SrcDist - Hackage.Tar - Hackage.Types - Hackage.Update - Hackage.Upload - Hackage.Utils + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.Config + Distribution.Client.Dependency + Distribution.Client.Dependency.Bogus + Distribution.Client.Dependency.TopDown + Distribution.Client.Dependency.TopDown.Constraints + Distribution.Client.Dependency.TopDown.Types + Distribution.Client.Dependency.Types + Distribution.Client.Fetch + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.List + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SrcDist + Distribution.Client.Tar + Distribution.Client.Types + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.Win32SelfUpgrade build-depends: Cabal >= 1.4 && < 1.5, filepath >= 1.0, @@ -90,3 +90,6 @@ if os(windows) build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 + else + build-depends: unix >= 2.2 && < 2.4 + extensions: CPP