diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs --- a/Cabal2Ebuild.hs +++ b/Cabal2Ebuild.hs @@ -24,8 +24,7 @@ module Cabal2Ebuild (cabal2ebuild ,convertDependencies - ,convertDependency - ,default_ghc_dependency) where + ,convertDependency) where import qualified Distribution.PackageDescription as Cabal (PackageDescription(..)) @@ -43,9 +42,6 @@ import qualified Portage.EBuild as E import Portage.Version -default_ghc_dependency :: Dependency -default_ghc_dependency = OrLaterVersionOf (Version [6,8,1] Nothing [] 0) (Portage.mkPackageName "dev-lang" "ghc") - cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild cabal2ebuild pkg = Portage.ebuildTemplate { E.name = map toLower cabalPkgName, @@ -53,7 +49,6 @@ E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg else Cabal.synopsis pkg, E.homepage = thisHomepage, - E.src_uri = thisSRC_URI, E.license = Cabal.license pkg, E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, E.features = E.features E.ebuildTemplate @@ -67,9 +62,6 @@ thisHomepage = if (null $ Cabal.homepage pkg) then E.homepage E.ebuildTemplate else Cabal.homepage pkg - thisSRC_URI = if (null $ Cabal.pkgUrl pkg) - then E.src_uri E.ebuildTemplate - else Cabal.pkgUrl pkg convertDependencies :: Portage.Category -> [Cabal.Dependency] -> [Dependency] convertDependencies category = concatMap (convertDependency category) @@ -93,7 +85,8 @@ )(\v -> [OrEarlierVersionOf (fromCabalVersion v) pn] -- ^ @\"<= v\"@ )(\v _ -> [ThisMajorOf (fromCabalVersion v) pn] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper) )(\g1 g2 -> [DependEither (flatten g1 ++ flatten g2) ] -- ^ @\"_ || _\"@ union - )(\r1 r2 -> r1 ++ r2 + )(\r1 r2 -> r1 ++ r2 -- ^ @\"_ && _\"@ intersection + )(\dp -> [AllOf dp ] -- ^ @\"(_)\"@ parentheses ) where flatten :: [Dependency] -> [[Dependency]] diff --git a/Error.hs b/Error.hs --- a/Error.hs +++ b/Error.hs @@ -1,4 +1,5 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} + module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where import Data.Typeable diff --git a/Main-GuessGHC.hs b/Main-GuessGHC.hs new file mode 100644 --- /dev/null +++ b/Main-GuessGHC.hs @@ -0,0 +1,27 @@ +module Main where + +import System.Environment + +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse + +import Distribution.Text +import Distribution.Verbosity + +import Portage.GHCCore + +main :: IO () +main = do + args <- getArgs + gpds <- mapM (readPackageDescription silent) args + mapM_ guess gpds + +guess :: GenericPackageDescription -> IO () +guess gpd = do + let pkg = package . packageDescription $ gpd + let mghc = minimumGHCVersionToBuildPackage gpd + putStr (display pkg) + putStr "\t\t" + putStrLn $ case mghc of + Nothing -> "Unknown" + Just (compiler, _pkgs) -> display compiler diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -14,15 +14,13 @@ , flagToList , optionVerbosity ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command -- commandsRun import Distribution.Simple.Utils ( die, cabalVersion, warn ) import qualified Distribution.PackageDescription.Parse as Cabal import qualified Distribution.Package as Cabal import Distribution.Verbosity (Verbosity, normal) -import Distribution.Text (display) +import Distribution.Text (display, simpleParse) import Distribution.Client.Types import Distribution.Client.Update @@ -40,9 +38,6 @@ import System.Exit ( exitFailure ) import System.FilePath ( () ) -import qualified Cabal2Ebuild as C2E -import qualified Portage.EBuild as E - import Diff import Error import Status @@ -145,15 +140,18 @@ } makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO () -makeEbuildAction flags args _globalFlags = do - when (null args) $ - die "make-ebuild needs at least one argument" - let _verbosity = fromFlag (makeEbuildVerbosity flags) - forM_ args $ \cabalFileName -> do +makeEbuildAction flags args globalFlags = do + (catstr,cabals) <- case args of + (category:cabal1:cabaln) -> return (category, cabal1:cabaln) + _ -> throwEx (ArgumentError "make-ebuild needs at least two arguments. ") + cat <- case simpleParse catstr of + Just c -> return c + Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr)) + let verbosity = fromFlag (makeEbuildVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + forM_ cabals $ \cabalFileName -> do pkg <- Cabal.readPackageDescription normal cabalFileName - let ebuild = C2E.cabal2ebuild (flattenPackageDescription pkg) - let ebuildFileName = E.name ebuild ++ "-" ++ E.version ebuild ++ ".ebuild" - writeFile ebuildFileName (display ebuild) + mergeGenericPackageDescription verbosity overlayPath cat pkg False makeEbuildCommand :: CommandUI MakeEbuildFlags makeEbuildCommand = CommandUI { diff --git a/MaybeRead.hs b/MaybeRead.hs deleted file mode 100644 --- a/MaybeRead.hs +++ /dev/null @@ -1,14 +0,0 @@ -module MaybeRead where - -import Data.List(find) -import Text.Read -import Text.ParserCombinators.ReadP - -readMaybe :: Read a => String -> Maybe a -readMaybe = readsMaybe reads - -readsMaybe :: ReadS a -> String -> Maybe a -readsMaybe func str = maybe Nothing (\x->Just (fst x)) (find (null.snd) (func str)) - -readPMaybe :: ReadP a -> String -> Maybe a -readPMaybe = readsMaybe.readP_to_S diff --git a/Merge.hs b/Merge.hs --- a/Merge.hs +++ b/Merge.hs @@ -1,15 +1,18 @@ {-# OPTIONS -XPatternGuards #-} module Merge - ( merge ) where + ( merge + , mergeGenericPackageDescription + ) where import Control.Monad.Error import Control.Exception import Data.Maybe import Data.List import Distribution.Package -import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) +-- import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) import Distribution.PackageDescription ( PackageDescription(..) , FlagName(..) + , GenericPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) @@ -46,6 +49,8 @@ import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage +import qualified Portage.GHCCore as GHCCore + import qualified Merge.Dependencies as Merge import Debug.Trace ( trace ) @@ -141,12 +146,13 @@ info verbosity $ match_text ++ (display . packageInfoId $ avail) let cabal_pkgId = packageInfoId selectedPkg - norm_pkgId = Portage.normalizeCabalPackageId cabal_pkgId - norm_pkgName = packageName norm_pkgId + norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId) cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category + mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True - let pkgGenericDesc = packageDescription selectedPkg - Right (pkgDesc0, flags) = +mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> GenericPackageDescription -> Bool -> IO () +mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do + let Right (pkgDesc0, flags) = finalizePackageDescription [ -- XXX: common things we should enable/disable? -- (FlagName "small_base", True) -- try to use small base @@ -155,29 +161,37 @@ (\dep -> trace ("accepting dep(?): " ++ display dep) True) -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier)) buildPlatform - (CompilerId GHC (Cabal.Version [6,10,4] [])) + (fst GHCCore.defaultGHC) [] pkgGenericDesc + + mminimumGHC = GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc + (compilerId, excludePkgs) = maybe GHCCore.defaultGHC id mminimumGHC + pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr) | Dependency pn vr <- buildDepends pkgDesc0 + , pn `notElem` excludePkgs ] in pkgDesc0 { buildDepends = deps } - edeps = Merge.resolveDependencies pkgDesc + edeps = Merge.resolveDependencies pkgDesc (Just compilerId) debug verbosity ("Selected flags: " ++ show flags) + info verbosity ("Guessing GHC version: " ++ maybe "could not guess" (display.fst) mminimumGHC) - let ebuild = fixSrc serverURI (packageId pkgDesc) - . (\e -> e { E.depend = Merge.dep edeps } ) + let ebuild = (\e -> e { E.depend = Merge.dep edeps } ) . (\e -> e { E.depend_extra = Merge.dep_e edeps } ) . (\e -> e { E.rdepend = Merge.rdep edeps } ) . (\e -> e { E.rdepend_extra = Merge.rdep_e edeps } ) $ C2E.cabal2ebuild pkgDesc mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild - fetchAndDigest - verbosity - (overlayPath display cat display norm_pkgName) - (display cabal_pkgId <.> "tar.gz") - (mkUri cabal_pkgId) + when fetch $ do + let cabal_pkgId = packageId pkgDesc + norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId) + fetchAndDigest + verbosity + (overlayPath display cat display norm_pkgName) + (display cabal_pkgId <.> "tar.gz") + (mkUri cabal_pkgId) mkUri :: Cabal.PackageIdentifier -> URI mkUri pid = @@ -224,20 +238,3 @@ createDirectoryIfMissing True edir info verbosity $ "Writing " ++ elocal writeFile epath (display ebuild) - -fixSrc :: URI -> PackageIdentifier -> E.EBuild -> E.EBuild -fixSrc serverURI p ebuild = - ebuild { - E.src_uri = show $ serverURI { - uriPath = - uriPath serverURI - display (pkgName p) - display (pkgVersion p) - display (pkgName p) ++ "-" ++ display (pkgVersion p) - <.> "tar.gz" - }, - E.homepage = case E.homepage ebuild of - "" -> "http://hackage.haskell.org/package/" - ++ display (pkgName p) - x -> x - } diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -53,16 +53,23 @@ , extraLibs , buildTools , pkgconfigDepends - , hasLibs ) + , hasLibs + , specVersion + ) import Data.Maybe ( isNothing ) import Data.List ( nub ) import qualified Distribution.Package as Cabal +import qualified Distribution.Version as Cabal +import Distribution.Compiler +import qualified Portage.Version as Portage import qualified Portage.PackageId as Portage import qualified Portage.Dependency as Portage import qualified Cabal2Ebuild as C2E +import qualified Portage.GHCCore as GHCCore + import Debug.Trace ( trace ) -- | Dependencies of an ebuild @@ -83,8 +90,8 @@ dep_e = [] } -resolveDependencies :: PackageDescription -> EDep -resolveDependencies pkg = +resolveDependencies :: PackageDescription -> Maybe CompilerId -> EDep +resolveDependencies pkg mcompiler = edeps { dep = Portage.simplify_deps ( dep edeps), @@ -93,11 +100,13 @@ -- version as in dep } where + compiler = maybe (fst GHCCore.defaultGHC) id mcompiler + hasBuildableExes p = any (buildable . buildInfo) . executables $ p treatAsLibrary = (not . hasBuildableExes) pkg || hasLibs pkg haskell_deps = haskellDependencies pkg - cabal_dep = cabalDependency pkg - ghc_dep = ghcDependency pkg + cabal_dep = cabalDependency pkg compiler + ghc_dep = compilerIdToDependency compiler extra_libs = findCLibs pkg build_tools = buildToolsDependencies pkg pkg_config = pkgConfigDependencies pkg @@ -122,6 +131,7 @@ rdep = extra_libs ++ pkg_config } + --------------------------------------------------------------- -- Haskell packages --------------------------------------------------------------- @@ -135,19 +145,34 @@ -- Cabal Dependency --------------------------------------------------------------- -cabalDependency :: PackageDescription -> Portage.Dependency -cabalDependency pkg = +-- | Select the most restrictive dependency on Cabal, either the .cabal +-- file's descCabalVersion, or the Cabal GHC shipped with. +cabalDependency :: PackageDescription -> CompilerId -> Portage.Dependency +cabalDependency pkg (CompilerId GHC ghcVersion@(Cabal.Version versionNumbers _)) = head $ C2E.convertDependency (Portage.Category "dev-haskell") (Cabal.Dependency (Cabal.PackageName "Cabal") - (descCabalVersion pkg)) + finalCabalDep) + where + userCabalVersion = Cabal.orLaterVersion (specVersion pkg) + shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers + shippedCabalDep = maybe Cabal.anyVersion + (\shipped -> Cabal.intersectVersionRanges + (Cabal.thisVersion shipped) + (Cabal.laterVersion shipped)) + shippedCabalVersion + finalCabalDep = Cabal.simplifyVersionRange + (Cabal.intersectVersionRanges + userCabalVersion + shippedCabalDep) --------------------------------------------------------------- -- GHC Dependency --------------------------------------------------------------- -ghcDependency :: PackageDescription -> Portage.Dependency -ghcDependency _pkg = C2E.default_ghc_dependency - +compilerIdToDependency :: CompilerId -> Portage.Dependency +compilerIdToDependency (CompilerId GHC versionNumbers) = + Portage.OrLaterVersionOf (Portage.fromCabalVersion versionNumbers) (Portage.mkPackageName "dev-lang" "ghc") + --------------------------------------------------------------- -- C Libraries --------------------------------------------------------------- @@ -166,7 +191,6 @@ notFound = [ p | p <- allE, isNothing (staticTranslateExtraLib p) ] found = [ p | Just p <- map staticTranslateExtraLib allE ] - staticTranslateExtraLib :: String -> Maybe Portage.Dependency staticTranslateExtraLib lib = lookup lib m @@ -177,6 +201,7 @@ , ("pq", Portage.LaterVersionOf (Portage.Version [7] Nothing [] 0) (Portage.mkPackageName "virtual" "postgresql-base")) , ("ev", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "libev")) , ("expat", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "expat")) + , ("curl", Portage.AnyVersionOf (Portage.mkPackageName "net-misc" "curl")) ] --------------------------------------------------------------- @@ -234,14 +259,20 @@ table :: [(String, (String, String))] table = [("gconf-2.0", ("gnome-base", "gconf")) + ,("gthread-2.0", ("dev-libs", "glib")) -- should be slot 2 + ,("gio-2.0", ("dev-libs", "glib")) + ,("glib-2.0", ("dev-libs", "glib")) + ,("gobject-2.0", ("dev-libs", "glib")) + ,("gtk+-2.0", ("x11-libs", "gtk+")) -- should be slot 2 + ,("cairo", ("x11-libs", "cairo")) ,("cairo-ps", ("x11-libs", "cairo")) ,("cairo-pdf", ("x11-libs", "cairo")) ,("cairo-svg", ("x11-libs", "cairo")) -- need [svg] for dev-haskell/cairo + ,("pangocairo", ("x11-libs", "cairo")) ,("pango", ("x11-libs", "pango")) - ,("gio-2.0", ("dev-libs", "glib")) ,("libglade-2.0", ("gnome-base", "libglade")) ,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs")) ,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs")) @@ -257,4 +288,5 @@ ,("librsvg-2.0", ("gnome-base","librsvg")) ,("vte", ("x11-libs","vte")) ,("gtkglext-1.0", ("x11-libs","gtkglext")) + ,("curl", ("net-misc", "curl")) ] diff --git a/P2.hs b/P2.hs deleted file mode 100644 --- a/P2.hs +++ /dev/null @@ -1,104 +0,0 @@ -module P2 where - --- Module that respect categories. --- Possibly to replace Portage.hs when the rest of the project has been --- ported to this style. - -import BlingBling - -import Control.Arrow -import Control.Monad - -import qualified Distribution.PackageDescription as Cabal - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List - -import System.Directory -import System.FilePath - -import Text.Regex - -import qualified Portage.Version as Portage - -import Distribution.Text - -type Portage = PortageMap [Ebuild] -type PortageMap a = Map Package a - -data Ebuild = Ebuild { - ePackage :: Package, - eVersion :: Portage.Version, - eFilePath :: FilePath, - ePkgDesc :: Maybe Cabal.GenericPackageDescription } - deriving (Show) - -data Package = P { pCategory :: String, pPackage :: String } - deriving (Eq, Ord) - -instance Show Package where - show (P c p) = c ++ '/':p - -instance Eq Ebuild where - e1 == e2 = (ePackage e1, eVersion e1) == (ePackage e2, eVersion e2) - -instance Ord Ebuild where - compare e1 e2 = compare (ePackage e1, eVersion e1) - (ePackage e2, eVersion e2) - -lookupEbuildWith :: Portage -> Package -> (Ebuild -> Bool) -> Maybe Ebuild -lookupEbuildWith portage package comp = do - es <- Map.lookup package portage - List.find comp es - -getPackageList :: FilePath -> IO [Package] -getPackageList portdir = do - categories <- getDirectories portdir - packages <- fmap concat $ forMbling categories $ \c -> do - pkg <- getDirectories (portdir c) - return (map (P c) pkg) - return packages - -readPortagePackages :: FilePath -> [Package] -> IO Portage -readPortagePackages portdir packages0 = do - packages <- filterM (doesDirectoryExist . (portdir ) . show) packages0 - ebuild_map0 <- forM packages $ \package -> do - ebuilds <- getPackageVersions package - return (package, List.sort ebuilds) - let ebuild_map = filter (not . null . snd) ebuild_map0 - return $ Map.fromList ebuild_map - - where - getPackageVersions :: Package -> IO [Ebuild] - getPackageVersions (P category package) = do - files <- getDirectoryContents (portdir category package) - let ebuilds = [ (v, portdir category package fn) - | (Just v, fn) <- map ((filterVersion package) &&& id) files ] - return (map (uncurry (\v f -> Ebuild (P category package) v f Nothing)) ebuilds) - - filterVersion :: String -> String -> Maybe Portage.Version - filterVersion p fn = do - [vstring] <- matchRegex (ebuildVersionRegex p) fn - simpleParse vstring - - ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$") - -readPortageTree :: FilePath -> IO Portage -readPortageTree portdir = do - packages <- getPackageList portdir - readPortagePackages portdir packages - -getDirectories :: FilePath -> IO [String] -getDirectories fp = do - files <- fmap (filter (`notElem` [".", ".."])) $ getDirectoryContents fp - filterM (doesDirectoryExist . (fp )) files - -printPortage :: Portage -> IO () -printPortage port = - forM_ (Map.toAscList port) $ \(package, ebuilds) -> do - let (P c p) = package - putStr $ c ++ '/':p - putStr " " - forM_ ebuilds (\e -> putStr (show $ eVersion e) >> putChar ' ') - putStrLn "" diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs --- a/Portage/Dependency.hs +++ b/Portage/Dependency.hs @@ -9,7 +9,7 @@ import Portage.PackageId import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ( (<>) ) +import Text.PrettyPrint ( (<>), hsep ) import Data.Maybe ( fromJust, catMaybes ) import Data.List ( nub, groupBy, partition, sortBy ) @@ -26,6 +26,7 @@ | DependEither [[Dependency]] -- || ( depend_group1 ..depend_groupN ) | DependIfUse UseFlag Dependency -- use? ( depend ) | ThisMajorOf Version PackageName -- =package-version* + | AllOf [Dependency] -- ( package-version* ) deriving (Eq,Show) instance Text Dependency where @@ -50,6 +51,7 @@ showDepend (DependIfUse useflag dep) = Disp.text useflag <> Disp.text "? " <> Disp.parens (disp dep) showDepend (ThisMajorOf v p) = Disp.char '=' <> disp p <-> disp v <> Disp.char '*' +showDepend (AllOf dp ) = Disp.text "( " <> hsep (map showDepend dp) <> Disp.text " )" {- Here goes code for dependencies simplification -} diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -1,6 +1,7 @@ module Portage.EBuild ( EBuild(..) , ebuildTemplate + , src_uri ) where import Distribution.Text ( Text(..), display ) @@ -19,7 +20,6 @@ hackportVersion :: String, description :: String, homepage :: String, - src_uri :: String, license :: Cabal.License, slot :: String, keywords :: [String], @@ -29,7 +29,7 @@ rdepend :: [Dependency], rdepend_extra :: [String], features :: [String], - my_pn :: Maybe String --If the package's name contains upper-case + my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters } getHackportVersion :: Version -> String @@ -43,7 +43,6 @@ hackportVersion = getHackportVersion Paths_hackport.version, description = "", homepage = "http://hackage.haskell.org/package/${PN}", - src_uri = "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz", license = Cabal.UnknownLicense "xxx UNKNOWN xxx", slot = "0", keywords = ["~amd64","~x86"], @@ -59,6 +58,18 @@ instance Text EBuild where disp = Disp.text . showEBuild +-- | Given an EBuild, give the URI to the tarball of the source code. +-- Assumes that the server is always hackage.haskell.org. +src_uri :: EBuild -> String +src_uri e = + case my_pn e of + -- use standard address given that the package name has no upper + -- characters + Nothing -> "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz" + -- use MY_X variables (defined in showEBuild) as we've renamed the + -- package + Just _ -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz" + showEBuild :: EBuild -> String showEBuild ebuild = ss "# Copyright 1999-2010 Gentoo Foundation". nl. @@ -76,7 +87,7 @@ ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl). ss "DESCRIPTION=". quote (description ebuild). nl. ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl. - ss "SRC_URI=". quote (replaceVars (src_uri ebuild)). nl. + ss "SRC_URI=". quote (src_uri ebuild). nl. nl. ss "LICENSE=". quote (convertLicense . license $ ebuild). (if null (licenseComment . license $ ebuild) then id @@ -91,8 +102,7 @@ Nothing -> id Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl) $ [] - where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild) - expandVars = replaceMultiVars [(name ebuild, "${PN}")] + where expandVars = replaceMultiVars [(name ebuild, "${PN}")] ss :: String -> String -> String ss = showString @@ -147,21 +157,6 @@ replaceMultiVars whole@((pname,cont):rest) str = case subStr cont str of Nothing -> replaceMultiVars rest str Just (pre,post) -> (replaceMultiVars rest pre)++pname++(replaceMultiVars whole post) - -replaceCommonVars :: - String -> -- ^ PN - Maybe String -> -- ^ MYPN - String -> -- ^ PV - String -> -- ^ the string to be replaced - String -replaceCommonVars pn mypn pv str - = replaceMultiVars - ([("${P}",pn++"-"++pv)] - ++ maybe [] (\x->[("${MY_P}",x++"-"++pv)]) mypn - ++[("${PN}",pn)] - ++ maybe [] (\x->[("${MY_PN}",x)]) mypn - ++[("${PV}",pv)]) str - -- map the cabal license type to the gentoo license string format convertLicense :: Cabal.License -> String diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs new file mode 100644 --- /dev/null +++ b/Portage/GHCCore.hs @@ -0,0 +1,305 @@ + +-- Guess GHC version from packages depended upon. +module Portage.GHCCore + ( minimumGHCVersionToBuildPackage + , cabalFromGHC + , defaultGHC + ) where + +import Distribution.Package +import Distribution.Version +import Distribution.Simple.PackageIndex +import Distribution.InstalledPackageInfo + +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) +import Distribution.System + +import Distribution.Text + +import Data.Maybe +import Data.List ( nub ) + +import Text.PrettyPrint.HughesPJ + +defaultGHC :: (CompilerId, [PackageName]) +defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix) + +ghcs :: [(CompilerId, PackageIndex)] +ghcs = [ghc682, ghc6101, ghc6104, ghc6121, ghc6122, ghc6123, ghc701] + +cabalFromGHC :: [Int] -> Maybe Version +cabalFromGHC ver = lookup ver table + where + table = [([6,6,0], Version [1,1,6] []) + ,([6,6,1], Version [1,1,6,2] []) + ,([6,8,1], Version [1,2,2,0] []) + ,([6,8,2], Version [1,2,3,0] []) + ,([6,8,3], Version [1,2,4,0] []) + ,([6,10,1], Version [1,6,0,1] []) + ,([6,10,2], Version [1,6,0,3] []) + ,([6,10,3], Version [1,6,0,3] []) + ,([6,10,4], Version [1,6,0,3] []) + ,([6,12,1], Version [1,8,0,2] []) + ,([6,12,2], Version [1,8,0,4] []) + ,([6,12,3], Version [1,8,0,6] []) + ,([7,0,1], Version [1,10,0,0] []) + ] + +platform :: Platform +platform = Platform X86_64 Linux + +packageIsCore :: PackageIndex -> PackageName -> Bool +packageIsCore index pn = not . null $ lookupPackageName index pn + +packageIsCoreInAnyGHC :: PackageName -> Bool +packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs) + +-- | Check if a dependency is satisfiable given a 'PackageIndex' +-- representing the core packages in a GHC version. +-- Packages that are not core will always be accepted, packages that are +-- core in any ghc must be satisfied by the 'PackageIndex'. +dependencySatisfiable :: PackageIndex -> Dependency -> Bool +dependencySatisfiable pi dep@(Dependency pn rang) + | pn == PackageName "Win32" = False -- only exists on windows, not in linux + | not . null $ lookupDependency pi dep = True -- the package index satisfies the dep + | packageIsCoreInAnyGHC pn = False -- some other ghcs support the dependency + | otherwise = True -- the dep is not related with core packages, accept the dep + +packageBuildableWithGHCVersion + :: GenericPackageDescription + -> (CompilerId, PackageIndex) + -> Either [Dependency] (PackageDescription, FlagAssignment) +packageBuildableWithGHCVersion pkg (compiler, pkgIndex) = + finalizePackageDescription [] (dependencySatisfiable pkgIndex) platform compiler [] pkg + +-- | Given a 'GenericPackageDescription' it returns the miminum GHC version +-- to build a package, and a list of core packages to that GHC version. +minimumGHCVersionToBuildPackage :: GenericPackageDescription -> Maybe (CompilerId, [PackageName]) +minimumGHCVersionToBuildPackage gpd = + listToMaybe [ (cid, packageNamesFromPackageIndex pix) + | g@(cid, pix) <- ghcs + , Right _ <- return (packageBuildableWithGHCVersion gpd g)] + +mkIndex :: [PackageIdentifier] -> PackageIndex +mkIndex pids = fromList + [ emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version + , sourcePackageId = pi + , exposed = True + } + | pi@(PackageIdentifier name version) <- pids ] + +packageNamesFromPackageIndex :: PackageIndex -> [PackageName] +packageNamesFromPackageIndex pix = nub $ + [ (pkgName . sourcePackageId) p | (p:_) <- allPackagesByName pix ] + +ghc :: [Int] -> CompilerId +ghc nrs = CompilerId GHC (Version nrs []) + +-- | Core packages in GHC 7.0.1 as a 'PackageIndex'. +ghc701 :: (CompilerId, PackageIndex) +ghc701 = (ghc [7,0,1], mkIndex ghc701_pkgs) + +ghc6123 :: (CompilerId, PackageIndex) +ghc6123 = (ghc [6,12,3], mkIndex ghc6123_pkgs) + +ghc6122 :: (CompilerId, PackageIndex) +ghc6122 = (ghc [6,12,2], mkIndex ghc6122_pkgs) + +ghc6121 :: (CompilerId, PackageIndex) +ghc6121 = (ghc [6,12,1], mkIndex ghc6121_pkgs) + +ghc6104 :: (CompilerId, PackageIndex) +ghc6104 = (ghc [6,10,4], mkIndex ghc6104_pkgs) + +ghc6101 :: (CompilerId, PackageIndex) +ghc6101 = (ghc [6,10,1], mkIndex ghc6101_pkgs) + +ghc682 :: (CompilerId, PackageIndex) +ghc682 = (ghc [6,8,2], mkIndex ghc682_pkgs) + +-- | Non-upgradeable core packages +-- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC +ghc701_pkgs :: [PackageIdentifier] +ghc701_pkgs = + [ p "array" [0,3,0,2] + , p "base" [4,3,0,0] + , p "bytestring" [0,9,1,8] +-- , p "Cabal" [1,10,0,0] package is upgradeable + , p "containers" [0,4,0,0] + , p "directory" [1,1,0,0] + , p "extensible-exceptions" [0,1,1,2] + , p "filepath" [1,2,0,0] + , p "haskell2010" [1,0,0,0] + , p "haskell98" [1,1,0,0] + , p "hpc" [0,5,0,6] + , p "integer-gmp" [0,2,0,2] + , p "integer-simple" [0,1,0,0] + , p "old-locale" [1,0,0,2] + , p "old-time" [1,0,0,6] + , p "pretty" [1,0,1,2] + , p "process" [1,0,1,4] + , p "random" [1,0,0,3] + , p "syb" [0,2,2] -- not distributed with ghc-7, but ghc-7 PDEPENDs on it + , p "template-haskell" [2,5,0,0] +-- , p "time" [1,2,0,3] package is upgradeable + , p "unix" [2,4,1,0] +-- , p "utf8-string" [0,3,4] package is upgradeable + ] + +ghc6123_pkgs :: [PackageIdentifier] +ghc6123_pkgs = + [ p "array" [0,3,0,1] + , p "base" [3,0,3,2] + , p "base" [4,2,0,2] + , p "bytestring" [0,9,1,7] +-- , p "Cabal" [1,8,0,6] package is upgradeable + , p "containers" [0,3,0,0] + , p "directory" [1,0,1,1] + , p "extensible-exceptions" [0,1,1,1] + , p "filepath" [1,1,0,4] + , p "haskell98" [1,0,1,1] + , p "hpc" [0,5,0,5] + , p "integer-gmp" [0,2,0,1] + , p "integer-simple" [0,1,0,0] + , p "old-locale" [1,0,0,2] + , p "old-time" [1,0,0,5] + , p "pretty" [1,0,1,1] + , p "process" [1,0,1,3] + , p "random" [1,0,0,2] + , p "syb" [0,1,0,2] + , p "template-haskell" [2,4,0,1] +-- , p "time" [1,1,4] package is upgradeable + , p "unix" [2,4,0,2] +-- , p "utf8-string" [0,3,4] package is upgradeable + ] + +ghc6122_pkgs :: [PackageIdentifier] +ghc6122_pkgs = + [ p "array" [0,3,0,0] + , p "base" [3,0,3,2] + , p "base" [4,2,0,1] + , p "bytestring" [0,9,1,6] +-- , p "Cabal" [1,8,0,4] package is upgradeable + , p "containers" [0,3,0,0] + , p "directory" [1,0,1,1] + , p "extensible-exceptions" [0,1,1,1] + , p "filepath" [1,1,0,4] + , p "haskell98" [1,0,1,1] + , p "hpc" [0,5,0,5] + , p "integer-gmp" [0,2,0,1] + , p "integer-simple" [0,1,0,0] + , p "old-locale" [1,0,0,2] + , p "old-time" [1,0,0,4] + , p "pretty" [1,0,1,1] + , p "process" [1,0,1,2] + , p "random" [1,0,0,2] + , p "syb" [0,1,0,2] + , p "template-haskell" [2,4,0,1] +-- , p "time" [1,1,4] package is upgradeable + , p "unix" [2,4,0,1] +-- , p "utf8-string" [0,3,4] package is upgradeable + ] + +ghc6121_pkgs :: [PackageIdentifier] +ghc6121_pkgs = + [ p "array" [0,3,0,0] + , p "base" [3,0,3,2] + , p "base" [4,2,0,0] + , p "bytestring" [0,9,1,5] +-- , p "Cabal" [1,8,0,2] package is upgradeable + , p "containers" [0,3,0,0] + , p "directory" [1,0,1,0] + , p "extensible-exceptions" [0,1,1,1] + , p "filepath" [1,1,0,3] + , p "haskell98" [1,0,1,1] + , p "hpc" [0,5,0,4] + , p "integer-gmp" [0,2,0,0] + , p "integer-simple" [0,1,0,0] + , p "old-locale" [1,0,0,2] + , p "old-time" [1,0,0,3] + , p "pretty" [1,0,1,1] + , p "process" [1,0,1,2] + , p "random" [1,0,0,2] + , p "syb" [0,1,0,2] + , p "template-haskell" [2,4,0,0] +-- , p "time" [1,1,4] package is upgradeable + , p "unix" [2,4,0,0] +-- , p "utf8-string" [0,3,4] package is upgradeable + ] + +ghc6104_pkgs :: [PackageIdentifier] +ghc6104_pkgs = + [ p "array" [0,2,0,0] + , p "base" [3,0,3,1] + , p "base" [4,1,0,0] + , p "bytestring" [0,9,1,4] +-- , p "Cabal" [1,6,0,3] package is upgradeable + , p "containers" [0,2,0,1 ] + , p "directory" [1,0,0,3] + , p "extensible-exceptions" [0,1,1,0] + , p "filepath" [1,1,0,2] + , p "haskell98" [1,0,1,0] + , p "hpc" [0,5,0,3] + , p "old-locale" [1,0,0,1] + , p "old-time" [1,0,0,2] + , p "packedstring" [0,1,0,1] + , p "pretty" [1,0,1,0] + , p "process" [1,0,1,1] + , p "random" [1,0,0,1] + , p "syb" [0,1,0,1] + , p "template-haskell" [2,3,0,1] +-- , p "time" [1,1,4] package is upgradeable + , p "unix" [2,3,2,0] + ] + +ghc6101_pkgs :: [PackageIdentifier] +ghc6101_pkgs = + [ p "array" [0,2,0,0] + , p "base" [3,0,3,0] + , p "base" [4,0,0,0] + , p "bytestring" [0,9,1,4] +-- , p "Cabal" [1,6,0,1] package is upgradeable + , p "containers" [0,2,0,0] + , p "directory" [1,0,0,2] + , p "extensible-exceptions" [0,1,0,0] + , p "filepath" [1,1,0,1] + , p "haskell98" [1,0,1,0] + , p "hpc" [0,5,0,2] + , p "old-locale" [1,0,0,1] + , p "old-time" [1,0,0,1] + , p "packedstring" [0,1,0,1] + , p "pretty" [1,0,1,0] + , p "process" [1,0,1,0] + , p "random" [1,0,0,1] + , p "syb" [0,1,0,0] + , p "template-haskell" [2,3,0,0] + , p "unix" [2,3,1,0] + ] + +ghc682_pkgs :: [PackageIdentifier] +ghc682_pkgs = + [ p "array" [0,1,0,0] + , p "base" [3,0,1,0] + , p "bytestring" [0,9,0,1] +-- , p "Cabal" [1,2,3,0] package is upgradeable + , p "containers" [0,1,0,1] + , p "dictionary" [1,0,0,0] + , p "filepath" [1,1,0,0] + , p "haskell98" [1,0,1,0] + , p "hpc" [0,5,0,0] + , p "old-locale" [1,0,0,0] + , p "old-time" [1,0,0,0] + , p "packedstring" [0,1,0,0] + , p "pretty" [1,0,0,0] + , p "process" [1,0,0,0] + , p "random" [1,0,0,0] +-- , p "readline" [1,0,1,0] + , p "template-haskell" [2,2,0,0] + , p "unix" [2,3,0,0] + ] + +p :: String -> [Int] -> PackageIdentifier +p pn vs = PackageIdentifier (PackageName pn) (Version vs []) diff --git a/Portage/Host.hs b/Portage/Host.hs --- a/Portage/Host.hs +++ b/Portage/Host.hs @@ -5,14 +5,14 @@ import Util (run_cmd) import Data.Char (isSpace) -import Data.Maybe (fromJust, isJust) - +import Data.Maybe (fromJust, isJust, catMaybes) +import Control.Applicative ( (<$>) ) data LocalInfo = LocalInfo { distfiles_dir :: String , overlay_list :: [FilePath] , portage_dir :: FilePath - } + } deriving Show defaultInfo :: LocalInfo defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles" @@ -23,8 +23,8 @@ -- query paludis and then emerge getInfo :: IO LocalInfo getInfo = fromJust `fmap` - performMaybes [ (fmap . fmap) parse_paludis_output (run_cmd "paludis --info") - , (fmap . fmap) parse_emerge_output (run_cmd "emerge --info") + performMaybes [ getPaludisInfo + , fmap parse_emerge_output <$> (run_cmd "emerge --info") , return (Just defaultInfo) ] where performMaybes [] = return Nothing @@ -34,58 +34,51 @@ then return r else performMaybes acts -data LocalPaludisOverlay = - LocalPaludisOverlay { repo_name :: String - , format :: String - , location :: FilePath - , distdir :: FilePath - } +---------- +-- Paludis +---------- -bad_paludis_overlay :: LocalPaludisOverlay -bad_paludis_overlay = - LocalPaludisOverlay { repo_name = undefined - , format = undefined - , location = undefined - , distdir = undefined - } +getPaludisInfo :: IO (Maybe LocalInfo) +getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "paludis --info" -parse_paludis_output :: String -> LocalInfo -parse_paludis_output raw_data = - foldl updateInfo defaultInfo $ parse_paludis_overlays raw_data - where updateInfo info po = - case (format po) of - "ebuild" | (repo_name po) /= "gentoo" -- hack, skip main repo - -> info{ distfiles_dir = distdir po -- we override last distdir here (FIXME?) - , overlay_list = (location po) : overlay_list info - } - "ebuild" -- hack, main repo -- (repo_name po) == "gentoo" - -> info{ portage_dir = location po } +parsePaludisInfo :: String -> LocalInfo +parsePaludisInfo text = + let chunks = splitBy (=="") . lines $ text + repositories = catMaybes (map parseRepository chunks) + in fromJust (mkLocalInfo repositories) + where + parseRepository :: [String] -> Maybe (String, (String, String)) + parseRepository (firstLine:lns) = do + name <- case words firstLine of + ["Repository", nm] -> return (init nm) + _ -> fail "not a repository chunk" + let dict = [ (head ln, unwords (tail ln)) | ln <- map words lns ] + location <- lookup "location:" dict + distfiles <- lookup "distdir:" dict + return (name, (location, distfiles)) - _ -> info + knownRepos = ["installed-virtuals", "virtuals", "gentoo", "installed"] -parse_paludis_overlays :: String -> [LocalPaludisOverlay] -parse_paludis_overlays raw_data = - parse_paludis_overlays' (reverse $ lines raw_data) bad_paludis_overlay + mkLocalInfo :: [(String, (String, String))] -> Maybe LocalInfo + mkLocalInfo repos = do + (gentooLocation, gentooDistfiles) <- lookup "gentoo" repos + let overlays = [ loc | (name, (loc, _dist)) <- repos, name `notElem` knownRepos ] + return (LocalInfo + { distfiles_dir = gentooDistfiles + , portage_dir = gentooLocation + , overlay_list = overlays + }) --- parse in reverse order :] -parse_paludis_overlays' :: [String] -> LocalPaludisOverlay -> [LocalPaludisOverlay] -parse_paludis_overlays' [] _ = [] -parse_paludis_overlays' (l:ls) info = - case (words l) of - -- look for "Repository :" - ["Repository", r_name] -> info{repo_name = init r_name} : - go bad_paludis_overlay - -- else - parse attributes - _ -> case (break (== ':') (refine l)) of - ("location", ':':value) - -> go info{location = refine value} - ("distdir", ':':value) - -> go info{distdir = refine value} - ("format", ':':value) - -> go info{format = refine value} - _ -> go info - where go = parse_paludis_overlays' ls - refine = dropWhile isSpace +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy c [] = [] +splitBy c lst = + let (x,xs) = break c lst + (_,xs') = span c xs + in x : splitBy c xs' + +--------- +-- Emerge +--------- parse_emerge_output :: String -> LocalInfo parse_emerge_output raw_data = diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs new file mode 100644 --- /dev/null +++ b/Portage/Metadata.hs @@ -0,0 +1,31 @@ +module Portage.Metadata + ( Metadata(..) + , metadataFromFile + ) where + +import qualified Data.ByteString as B + +import Control.Applicative + +import Text.XML.Light + +import Control.Monad + +data Metadata = Metadata + { metadataHerds :: [String] + -- , metadataMaintainers :: [String], + -- , metadataUseFlags :: [(String,String)] + } deriving (Show) + +metadataFromFile :: FilePath -> IO (Maybe Metadata) +metadataFromFile fp = do + doc <- parseXMLDoc <$> B.readFile fp + return (doc >>= parseMetadata) + +parseMetadata :: Element -> Maybe Metadata +parseMetadata xml = do + let herds = map strContent (findChildren (unqual "herd") xml) + return Metadata + { + metadataHerds = herds + } diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs --- a/Portage/Overlay.hs +++ b/Portage/Overlay.hs @@ -1,19 +1,22 @@ module Portage.Overlay ( ExistingEbuild(..) , Overlay(..) - , load, loadLazy - , readOverlayByPackage, getDirectoryTree, DirectoryTree + , loadLazy + , readOverlay, readOverlayByPackage + , getDirectoryTree, DirectoryTree , reduceOverlay + , filterByHerd , inOverlay ) where import qualified Portage.PackageId as Portage +import qualified Portage.Metadata as Portage import qualified Distribution.Package as Cabal -import Distribution.Text (simpleParse, display) +import Distribution.Text (simpleParse) import Distribution.Simple.Utils ( comparing, equating ) import Data.List as List @@ -23,14 +26,8 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.FilePath ((), splitExtension) ---main = do --- pkgs <- blingProgress . Progress.fromList . readOverlay --- =<< getDirectoryTree "." --- putStrLn $ unlines [ display pkg --- | pkg <- pkgs --- , isNothing (Portage.toCabalPackageId pkg) ] +import Data.Traversable ( traverse ) ---TODO: move this to another module: data ExistingEbuild = ExistingEbuild { ebuildId :: Portage.PackageId, ebuildCabalId :: Cabal.PackageIdentifier, @@ -41,7 +38,8 @@ data Overlay = Overlay { overlayPath :: FilePath, - overlayMap :: Map Portage.PackageName [ExistingEbuild] + overlayMap :: Map Portage.PackageName [ExistingEbuild], + overlayMetadata :: Map Portage.PackageName Portage.Metadata } deriving Show inOverlay :: Overlay -> Cabal.PackageId -> Bool @@ -58,41 +56,55 @@ in cabal_pn == overlay_pn && (not (null ebs))) om om = overlayMap overlay -load :: FilePath -> IO Overlay -load dir = fmap (mkOverlay . readOverlay) (getDirectoryTree dir) - where - mkOverlay _packages = Overlay { - overlayPath = dir --- TODO: ignore all ebuilds that have no Cabal version number --- , overlayIndex = PackageIndex.fromList packages - , overlayMap = undefined - } - loadLazy :: FilePath -> IO Overlay -loadLazy dir = fmap (mkOverlay . readOverlayByPackage) (getDirectoryTree dir) +loadLazy path = do + dir <- getDirectoryTree path + metadata <- unsafeInterleaveIO $ mkMetadataMap path dir + return $ mkOverlay metadata $ readOverlayByPackage dir where allowed v = case v of (Portage.Version _ Nothing [] _) -> True _ -> False - a <-> b = a ++ '-':b - a <.> b = a ++ '.':b - mkOverlay :: [(Portage.PackageName, [Portage.Version])] -> Overlay - mkOverlay packages = Overlay { - overlayPath = dir, + mkOverlay :: Map Portage.PackageName Portage.Metadata + -> [(Portage.PackageName, [Portage.Version])] + -> Overlay + mkOverlay meta packages = Overlay { + overlayPath = path, + overlayMetadata = meta, overlayMap = Map.fromList [ (pkgName, [ ExistingEbuild portageId cabalId filepath | version <- allowedVersions , let portageId = Portage.PackageId pkgName version , Just cabalId <- [ Portage.toCabalPackageId portageId ] - , let filepath = - dir display pkgName <-> display version <.> "ebuild" + , let filepath = path Portage.packageIdToFilePath portageId ]) | (pkgName, allVersions) <- packages , let allowedVersions = filter allowed allVersions ] } + +mkMetadataMap :: FilePath -> DirectoryTree -> IO (Map Portage.PackageName Portage.Metadata) +mkMetadataMap root dir = + fmap (Map.mapMaybe id) $ + traverse Portage.metadataFromFile $ + Map.fromList + [ (Portage.mkPackageName category package, root category package "metadata.xml") + | Directory category packages <- dir + , Directory package files <- packages + , File "metadata.xml" <- files + ] + +filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay +filterByHerd p overlay = overlay + { overlayMetadata = metadataMap' + , overlayMap = pkgMap' + } + where + metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay) + pkgMap' = Map.intersection (overlayMap overlay) metadataMap' + -- make sure there is only one ebuild for each version number (by selecting -- the highest ebuild version revision) diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs --- a/Portage/PackageId.hs +++ b/Portage/PackageId.hs @@ -10,7 +10,8 @@ toCabalPackageId, parseFriendlyPackage, normalizeCabalPackageName, - normalizeCabalPackageId + normalizeCabalPackageId, + packageIdToFilePath ) where import qualified Distribution.Package as Cabal @@ -23,9 +24,10 @@ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (isAlphaNum, isSpace, toLower) --- import qualified Data.Char as Char (isDigit) --- import Data.List (intersperse) +import Distribution.Text(display) +import System.FilePath ( () ) + newtype Category = Category { unCategory :: String } deriving (Eq, Ord, Show, Read) @@ -48,6 +50,13 @@ -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). -} + +packageIdToFilePath :: PackageId -> FilePath +packageIdToFilePath (PackageId (PackageName cat pn) version) = + display cat display pn display pn <-> display version <.> "ebuild" + where + a <-> b = a ++ '-':b + a <.> b = a ++ '.':b mkPackageName :: String -> String -> PackageName mkPackageName cat package = PackageName (Category cat) (Cabal.PackageName package) diff --git a/Status.hs b/Status.hs --- a/Status.hs +++ b/Status.hs @@ -6,8 +6,10 @@ ) where import AnsiColor -import P2 +import Portage.Overlay +import Portage.PackageId + import Control.Monad.State import qualified Data.List as List @@ -19,11 +21,13 @@ import Data.Map as Map (Map) import qualified Data.Traversable as T +import Control.Applicative -- cabal import Distribution.Verbosity import Distribution.Simple.Utils (equating, comparing) -import Distribution.Text(display) +import Distribution.Text ( display, simpleParse ) +import Distribution.Simple.Utils ( die ) data FileStatus a = Same a @@ -51,20 +55,20 @@ OverlayOnly a -> a PortageOnly a -> a -status :: Verbosity -> FilePath -> FilePath -> IO (Map Package [FileStatus Ebuild]) -status _verbosity portdir overlayPath = do - overlay <- readPortageTree overlayPath - portage <- readPortagePackages portdir (Map.keys overlay) - let (over, both, port) = portageDiff overlay portage +status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild]) +status _verbosity portdir overlaydir = do + overlay <- loadLazy overlaydir + portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir + let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) both' <- T.forM both $ mapM $ \e -> liftIO $ do -- can't fail, we know the ebuild exists in both portagedirs -- also, one of them is already bound to 'e' - let (Just e1) = lookupEbuildWith portage (ePackage e) (equating eVersion e) - (Just e2) = lookupEbuildWith overlay (ePackage e) (equating eVersion e) - eq <- equals (eFilePath e1) (eFilePath e2) + let (Just e1) = lookupEbuildWith (overlayMap portage) (ebuildId e) + (Just e2) = lookupEbuildWith (overlayMap overlay) (ebuildId e) + eq <- equals (ebuildPath e1) (ebuildPath e2) return $ if eq - then Same e + then Same e1 else Differs e1 e2 let meld = Map.unionsWith (\a b -> List.sort (a++b)) @@ -74,50 +78,59 @@ ] return meld +type EMap = Map PackageName [ExistingEbuild] + +lookupEbuildWith :: EMap -> PackageId -> Maybe ExistingEbuild +lookupEbuildWith overlay pkgid = do + ebuilds <- Map.lookup (packageId pkgid) overlay + List.find (\e -> ebuildId e == pkgid) ebuilds + runStatus :: Verbosity -> FilePath -> FilePath -> Bool -> [String] -> IO () -runStatus verbosity portdir overlayPath toPortageFlag pkgs = do +runStatus verbosity portdir overlaydir toPortageFlag pkgs = do let pkgFilter | toPortageFlag = toPortageFilter | otherwise = id - tree0 <- status verbosity portdir overlayPath + pkgs' <- forM pkgs $ \p -> + case simpleParse p of + Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg") + Just pn -> return pn + tree0 <- status verbosity portdir overlaydir let tree = pkgFilter tree0 - if (null pkgs) + if (null pkgs') then statusPrinter tree - else forM_ pkgs $ \pkg -> do - let filteredTree = Map.filterWithKey (\k _ -> pPackage k == pkg) tree - statusPrinter filteredTree + else forM_ pkgs' $ \pkg -> statusPrinter (Map.filterWithKey (\k _ -> k == pkg) tree) -- |Only return packages that seems interesting to sync to portage; -- -- * Ebuild differs, or -- * Newer version in overlay than in portage -toPortageFilter :: Map Package [FileStatus Ebuild] -> Map Package [FileStatus Ebuild] +toPortageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild] toPortageFilter = Map.mapMaybe $ \ sts -> let inPortage = flip filter sts $ \st -> case st of OverlayOnly _ -> False _ -> True - latestPortageVersion = List.maximum $ map (eVersion . fromStatus) inPortage + latestPortageVersion = List.maximum $ map (pkgVersion . ebuildId . fromStatus) inPortage interestingPackages = flip filter sts $ \st -> case st of Differs _ _ -> True - _ | eVersion (fromStatus st) > latestPortageVersion -> True + _ | pkgVersion (ebuildId (fromStatus st)) > latestPortageVersion -> True | otherwise -> False in if not (null inPortage) && not (null interestingPackages) then Just sts else Nothing -statusPrinter :: Map Package [FileStatus Ebuild] -> IO () +statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO () statusPrinter packages = do putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same" putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs" putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay" putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree" forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do - let (P c p) = pkg - putStr $ c ++ '/' : bold p + let (PackageName c p) = pkg + putStr $ display c ++ '/' : bold (display p) putStr " " forM_ ebuilds $ \e -> do - putStr $ toColor (fmap (display . eVersion) e) + putStr $ toColor (fmap (display . pkgVersion . ebuildId) e) putChar ' ' putStrLn "" @@ -130,15 +143,15 @@ (OverlayOnly _) -> Red (PortageOnly _) -> Magenta -portageDiff :: Portage -> Portage -> (Portage, Portage, Portage) + +portageDiff :: EMap -> EMap -> (EMap, EMap, EMap) portageDiff p1 p2 = (in1, ins, in2) - where ins = Map.filter (not . null) $ - Map.intersectionWith (List.intersectBy $ equating eVersion) p1 p2 + where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2 in1 = difference p1 p2 in2 = difference p2 p1 difference x y = Map.filter (not . null) $ Map.differenceWith (\xs ys -> - let lst = foldr (List.deleteBy (equating eVersion)) xs ys in + let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in if null lst then Nothing else Just lst diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs +++ /dev/null @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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(..) ) -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(..), PackageName(..), 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 - deriving Eq - -data Outcome = NotTried | Failed | Ok - deriving Eq - -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 - convertInstallOutcome = case result of - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - 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 - -cabalInstallID :: PackageIdentifier -cabalInstallID = - PackageIdentifier (PackageName "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 - -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 = Disp.render . ppFields 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/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 ) - -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , initialPathTemplateEnv, substPathTemplate ) -import Distribution.System - ( Platform(Platform) ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.Simple.Utils - ( comparing, equating ) - -import Data.List - ( groupBy, sortBy ) -import Data.Maybe - ( catMaybes ) -import System.FilePath - ( (), takeDirectory ) -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 :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () -storeLocal templates reports = sequence_ - [ do createDirectoryIfMissing True (takeDirectory file) - appendFile file output - --TODO: make this concurrency safe, either lock the report file or make - -- sure the writes for each report are atomic - | (file, reports') <- groupByFileName - [ (reportFileName template report, report) - | template <- templates - , (report, _repo) <- reports ] - , let output = concatMap format reports' - ] - where - format r = '\n' : BuildReport.show r ++ "\n" - - reportFileName template report = - fromPathTemplate (substPathTemplate env template) - where env = initialPathTemplateEnv - (BuildReport.package report) - (BuildReport.compiler report) - - groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) - . groupBy (equating fst) - . sortBy (comparing fst) - --- ------------------------------------------------------------ --- * InstallPlan support --- ------------------------------------------------------------ - -fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] -fromInstallPlan plan = catMaybes - . map (fromPlanPackage platform comp) - . InstallPlan.toList - $ plan - where platform = InstallPlan.planPlatform plan - comp = InstallPlan.planCompiler plan - -fromPlanPackage :: Platform -> CompilerId - -> InstallPlan.PlanPackage - -> Maybe (BuildReport, Repo) -fromPlanPackage (Platform arch os) 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/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildReports.Types --- Copyright : (c) Duncan Coutts 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Types related to build reporting --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Types ( - ReportLevel(..), - ) where - -import qualified Distribution.Text as Text - ( Text(..) ) - -import qualified Distribution.Compat.ReadP as Parse - ( pfail, munch1 ) -import qualified Text.PrettyPrint.HughesPJ as Disp - ( text ) - -import Data.Char as Char - ( isAlpha, toLower ) - -data ReportLevel = NoReports | AnonymousReports | DetailedReports - deriving (Eq, Ord, Show) - -instance Text.Text ReportLevel where - disp NoReports = Disp.text "none" - disp AnonymousReports = Disp.text "anonymous" - disp DetailedReports = Disp.text "detailed" - parse = do - name <- Parse.munch1 Char.isAlpha - case lowercase name of - "none" -> return NoReports - "anonymous" -> return AnonymousReports - "detailed" -> return DetailedReports - _ -> Parse.pfail - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# 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.TCP (HandleStream) -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 (HandleStream BuildLog) () -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 (HandleStream BuildLog) 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 (HandleStream BuildLog) () -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/cabal-install-0.8.2/Distribution/Client/Check.hs b/cabal-install-0.8.2/Distribution/Client/Check.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Check.hs +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Simple.Utils - ( defaultPackageDesc, toUTF8, wrapText ) - -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:" - printCheckMessages buildImpossible - - unless (null buildWarning) $ do - putStrLn "The following warnings are likely affect your build negatively:" - printCheckMessages buildWarning - - unless (null distSuspicious) $ do - putStrLn "These warnings may cause trouble when distributing the package:" - printCheckMessages distSuspicious - - unless (null distInexusable) $ do - putStrLn "The following errors will cause portability problems on other environments:" - printCheckMessages distInexusable - - 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) - - where - printCheckMessages = mapM_ (putStrLn . format . explanation) - format = toUTF8 . wrapText . ("* "++) diff --git a/cabal-install-0.8.2/Distribution/Client/Config.hs b/cabal-install-0.8.2/Distribution/Client/Config.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Config.hs +++ /dev/null @@ -1,565 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, - defaultConfigFile, - defaultCacheDir, - defaultLogsDir, - ) where - - -import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..) ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , 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, showFilePath, parseTokenQ ) -import qualified Distribution.ParseUtils as ParseUtils - ( Field(..) ) -import qualified Distribution.Text as Text - ( Text(..) ) -import Distribution.ReadE - ( readP_to_E ) -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.Verbosity - ( Verbosity, normal ) - -import Data.List - ( partition, find ) -import Data.Maybe - ( fromMaybe ) -import Data.Monoid - ( Monoid(..) ) -import Control.Monad - ( when, foldM, liftM ) -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, empty, isEmpty, nest ) -import Text.PrettyPrint.HughesPJ - ( (<>), (<+>), ($$), ($+$) ) -import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory ) -import Network.URI - ( URI(..), URIAuth(..) ) -import System.FilePath - ( (), takeDirectory ) -import System.Environment - ( getEnvironment ) -import System.IO.Error - ( isDoesNotExistError ) - --- --- * Configuration saved in the config file --- - -data SavedConfig = SavedConfig { - savedGlobalFlags :: GlobalFlags, - savedInstallFlags :: InstallFlags, - savedConfigureFlags :: ConfigFlags, - savedConfigureExFlags :: ConfigExFlags, - savedUserInstallDirs :: InstallDirs (Flag PathTemplate), - savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), - savedUploadFlags :: UploadFlags - } - -instance Monoid SavedConfig where - mempty = SavedConfig { - savedGlobalFlags = mempty, - savedInstallFlags = mempty, - savedConfigureFlags = mempty, - savedConfigureExFlags = mempty, - savedUserInstallDirs = mempty, - savedGlobalInstallDirs = mempty, - savedUploadFlags = mempty - } - mappend a b = SavedConfig { - savedGlobalFlags = combine savedGlobalFlags, - savedInstallFlags = combine savedInstallFlags, - savedConfigureFlags = combine savedConfigureFlags, - savedConfigureExFlags = combine savedConfigureExFlags, - 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 - logsDir <- defaultLogsDir - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = [defaultRemoteRepo] - }, - savedInstallFlags = mempty { - installSummaryFile = [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag AnonymousReports - } - } - -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 = True --- We do per-user installs by default on all platforms. We used to default to --- global installs on Windows but that no longer works on Windows Vista or 7. - -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 - let sources = [ - ("commandline option", return . flagToMaybe $ configFileFlag), - ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment), - ("default config file", Just `liftM` defaultConfigFile) ] - - getSource [] = error "no config file path candidate found." - getSource ((msg,action): xs) = - action >>= maybe (getSource xs) (return . (,) msg) - - (source, configFile) <- getSource sources - minp <- readConfigFile mempty configFile - case minp of - Nothing -> do - notice verbosity $ "Config file path source is " ++ source ++ "." - notice verbosity $ "Config file " ++ configFile ++ " not found." - notice verbosity $ "Writing default configuration to " ++ configFile - commentConf <- commentSavedConfig - initialConf <- initialSavedConfig - writeConfigFile configFile commentConf initialConf - return initialConf - 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 ++ ":\n" ++ 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 $ explanation ++ showConfigWithComments comments vals ++ "\n" - where - explanation = unlines - ["-- This is the configuration file for the 'cabal' command line tool." - ,"" - ,"-- The available configuration options are listed below." - ,"-- Some of them have default values listed." - ,"" - ,"-- Lines (like this one) beginning with '--' are comments." - ,"-- Be careful with spaces and indentation because they are" - ,"-- used to indicate layout for nested sections." - ,"","" - ] - --- | 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, - savedConfigureExFlags = defaultConfigExFlags, - 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 liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "configure-option"] ++ map fieldName installDirsFields) - - --FIXME: this is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleField "compiler" - (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs) - [] [] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "reinstall", "only"] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check"] [] - - where - toSavedConfig lift options exclusions replacements = - [ lift (fromMaybe field replacement) - | opt <- options - , let field = viewAsFieldDescr opt - name = fieldName field - replacement = find ((== name) . fieldName) replacements - , name `notElem` exclusions ] - optional = Parse.option mempty . fmap toFlag - --- 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 }) - -liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig -liftConfigExFlag = liftField - savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = 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 - let user0 = savedUserInstallDirs config - global0 = savedGlobalInstallDirs config - (user, global) <- foldM parseSections (user0, global0) 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 (fmap toFlag (readP_to_E err parseFilePathQ)) - (map (show . showFilePath) . flagToList) - where err _ = "paths with spaces must use Haskell String syntax" diff --git a/cabal-install-0.8.2/Distribution/Client/Configure.hs b/cabal-install-0.8.2/Distribution/Client/Configure.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Configure.hs +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Configure --- Copyright : (c) David Himmelstrup 2005, --- Duncan Coutts 2005 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- High level interface to configuring a package. ------------------------------------------------------------------------------ -module Distribution.Client.Configure ( - configure, - ) where - -import Data.Monoid - ( Monoid(mempty) ) -import qualified Data.Map as Map - -import Distribution.Client.Dependency - ( resolveDependenciesWithProgress - , PackageConstraint(..) - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) - , Progress(..), foldProgress, ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, getInstalledPackages ) -import Distribution.Client.Setup - ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) -import Distribution.Client.Types as Available - ( AvailablePackage(..), AvailablePackageSource(..), Repo(..) - , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) - -import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId) - , PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration ) -import Distribution.Simple.Setup - ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Simple.Utils - ( defaultPackageDesc ) -import Distribution.Package - ( PackageName, packageName, packageVersion - , Package(..), Dependency(..), thisPackageVersion ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Version - ( VersionRange, anyVersion, thisVersion ) -import Distribution.Simple.Utils as Utils - ( notice, info, die ) -import Distribution.System - ( Platform, buildPlatform ) -import Distribution.Verbosity as Verbosity - ( Verbosity ) - --- | Configure the package found in the local directory -configure :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> ConfigExFlags - -> [String] - -> IO () -configure verbosity packageDBs repos comp conf - configFlags configExFlags extraArgs = do - - installed <- getInstalledPackages verbosity comp packageDBs conf - available <- getAvailablePackages verbosity repos - - progress <- planLocalPackage verbosity comp configFlags configExFlags - installed available - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) - (return . Left) (return . Right) progress - case maybePlan of - Left message -> do - info verbosity message - setupWrapper verbosity (setupScriptOptions installed) Nothing - configureCommand (const configFlags) extraArgs - - Right installPlan -> case InstallPlan.ready installPlan of - [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] -> - configurePackage verbosity - (InstallPlan.planPlatform installPlan) - (InstallPlan.planCompiler installPlan) - (setupScriptOptions installed) - configFlags pkg extraArgs - - _ -> die $ "internal error: configure install plan should have exactly " - ++ "one local ready package." - - where - setupScriptOptions index = SetupScriptOptions { - useCabalVersion = maybe anyVersion thisVersion - (flagToMaybe (configCabalVersion configExFlags)), - useCompiler = Just comp, - -- Hack: we typically want to allow the UserPackageDB for finding the - -- Cabal lib when compiling any Setup.hs even if we're doing a global - -- install. However we also allow looking in a specific package db. - usePackageDB = if UserPackageDB `elem` packageDBs - then packageDBs - else packageDBs ++ [UserPackageDB], - usePackageIndex = if UserPackageDB `elem` packageDBs - then index - else Nothing, - useProgramConfig = conf, - useDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags), - useLoggingHandle = Nothing, - useWorkingDir = Nothing - } - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> ConfigFlags -> ConfigExFlags - -> Maybe (PackageIndex InstalledPackage) - -> AvailablePackageDb - -> IO (Progress String String InstallPlan) -planLocalPackage verbosity comp configFlags configExFlags installed - (AvailablePackageDb _ availablePrefs) = 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 mempty - installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed - localPkg = AvailablePackage { - packageInfoId = packageId pkg, - Available.packageDescription = pkg, - packageSource = LocalUnpackedPackage - } - targets = [packageName pkg] - constraints = [PackageVersionConstraint (packageName pkg) - (thisVersion (packageVersion pkg)) - ,PackageFlagsConstraint (packageName pkg) - (configConfigurationsFlags configFlags)] - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs PreferLatestForSelected - availablePrefs configExFlags - - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available' preferences constraints targets - - -mergePackagePrefs :: PackagesPreferenceDefault - -> Map.Map PackageName VersionRange - -> ConfigExFlags - -> PackagesPreference -mergePackagePrefs defaultPref availablePrefs configExFlags = - PackagesPreference defaultPref $ - -- The preferences that come from the hackage index - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] - -- additional preferences from the config file or command line - ++ [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] - --- | 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. --- -configurePackage :: Verbosity - -> Platform -> CompilerId - -> SetupScriptOptions - -> ConfigFlags - -> ConfiguredPackage - -> [String] - -> IO () -configurePackage verbosity platform comp scriptOptions configFlags - (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = - - setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags extraArgs - - where - configureFlags = filterConfigureFlags configFlags { - configConfigurationsFlags = flags, - configConstraints = map thisPackageVersion deps, - configVerbosity = toFlag verbosity - } - - pkg = case finalizePackageDescription flags - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePackageDescription ConfiguredPackage failed" - Right (desc, _) -> desc diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency.hs b/cabal-install-0.8.2/Distribution/Client/Dependency.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency.hs +++ /dev/null @@ -1,233 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 ( - module Distribution.Client.Dependency.Types, - resolveDependencies, - resolveDependenciesWithProgress, - - dependencyConstraints, - dependencyTargets, - - PackagesPreference(..), - PackagesPreferenceDefault(..), - PackagePreference(..), - - upgradableDependencies, - ) where - -import Distribution.Client.Dependency.Bogus (bogusResolver) -import Distribution.Client.Dependency.TopDown (topDownResolver) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.Types - ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, PackageConstraint(..) - , PackagePreferences(..), InstalledPreference(..) - , Progress(..), foldProgress ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), packageVersion, packageName - , Dependency(..), Package(..), PackageFixedDeps(..) ) -import Distribution.Version - ( VersionRange, anyVersion, orLaterVersion, isAnyVersion ) -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils (comparing) -import Distribution.Client.Utils (mergeBy, MergeResult(..)) - -import Data.List (maximumBy) -import Data.Monoid (Monoid(mempty)) -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Set (Set) -import Control.Exception (assert) - -defaultResolver :: DependencyResolver -defaultResolver = topDownResolver - --- | Global policy for the versions of all packages. --- -data PackagesPreference = PackagesPreference - PackagesPreferenceDefault - [PackagePreference] - -dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint] -dependencyConstraints deps = - [ PackageVersionConstraint name versionRange - | UnresolvedDependency (Dependency name versionRange) _ <- deps - , not (isAnyVersion versionRange) ] - - ++ [ PackageFlagsConstraint name flags - | UnresolvedDependency (Dependency name _) flags <- deps - , not (null flags) ] - -dependencyTargets :: [UnresolvedDependency] -> [PackageName] -dependencyTargets deps = - [ name | UnresolvedDependency (Dependency name _) _ <- deps ] - --- | Global policy for all packages to say if we prefer package versions that --- are already installed locally or if we just prefer the latest available. --- -data PackagesPreferenceDefault = - - -- | 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 - -data PackagePreference - = PackageVersionPreference PackageName VersionRange - | PackageInstalledPreference PackageName InstalledPreference - -resolveDependencies :: Platform - -> CompilerId - -> Maybe (PackageIndex InstalledPackage) - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Either String InstallPlan -resolveDependencies platform comp installed available - preferences constraints targets = - foldProgress (flip const) Left Right $ - resolveDependenciesWithProgress platform comp installed available - preferences constraints targets - -resolveDependenciesWithProgress :: Platform - -> CompilerId - -> Maybe (PackageIndex InstalledPackage) - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Progress String String InstallPlan -resolveDependenciesWithProgress platform comp (Just installed) = - dependencyResolver defaultResolver platform comp installed - -resolveDependenciesWithProgress platform comp Nothing = - dependencyResolver bogusResolver platform 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 - -dependencyResolver - :: DependencyResolver - -> Platform -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Progress String String InstallPlan -dependencyResolver resolver platform comp installed available - pref constraints targets = - let installed' = hideBrokenPackages installed - -- If the user is not explicitly asking to upgrade base then lets - -- prevent that from happening accidentally since it is usually not what - -- you want and it probably does not work anyway. We do it by adding a - -- constraint to only pick an installed version of base and ghc-prim. - extraConstraints = - [ PackageInstalledConstraint pkgname - | all (/=PackageName "base") targets - , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] - , not (null (PackageIndex.lookupPackageName installed pkgname)) ] - preferences = interpretPackagesPreference (Set.fromList targets) pref - in fmap toPlan - $ resolver platform comp installed' available - preferences (extraConstraints ++ constraints) targets - - where - toPlan pkgs = - case InstallPlan.new platform 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 - --- | Give an interpretation to the global 'PackagesPreference' as --- specific per-package 'PackageVersionPreference'. --- -interpretPackagesPreference :: Set PackageName - -> PackagesPreference - -> (PackageName -> PackagePreferences) -interpretPackagesPreference selected (PackagesPreference defaultPref prefs) = - \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) - - where - versionPref pkgname = - fromMaybe anyVersion (Map.lookup pkgname versionPrefs) - versionPrefs = Map.fromList - [ (pkgname, pref) - | PackageVersionPreference pkgname pref <- prefs ] - - installPref pkgname = - fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) - installPrefs = Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs ] - installPrefDefault = case defaultPref of - PreferAllLatest -> \_ -> PreferLatest - PreferAllInstalled -> \_ -> 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 InstalledPackage - -> 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/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - ( AvailablePackage(..), ConfiguredPackage(..) ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, Progress(..) - , PackageConstraint(..), PackagePreferences(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan - -import Distribution.Package - ( PackageName, PackageIdentifier(..), Dependency(..) - , Package(..), packageVersion ) -import Distribution.PackageDescription - ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Version - ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) -import Distribution.Simple.Utils - ( comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( maximumBy ) -import Data.Maybe - ( fromMaybe ) -import qualified Data.Map as Map - --- | 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 platform comp _ available - preferences constraints targets = - resolveFromAvailable [] - (combineConstraints preferences constraints targets) - where - resolveFromAvailable chosen [] = Done chosen - resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) = - case latestAvailableSatisfying available name verConstraint verPref of - Nothing -> Fail ("Unresolved dependency: " ++ display dep) - Just apkg@(AvailablePackage _ pkg _) -> - case finalizePackageDescription flags none platform 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 :: Dependency -> Bool - none = const True - where - dep = Dependency name verConstraint - -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) - -combineConstraints :: (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> [(PackageName, VersionRange, FlagAssignment, VersionRange)] -combineConstraints preferences constraints targets = - [ (name, ver, flags, pref) - | name <- targets - , let ver = fromMaybe anyVersion (Map.lookup name versionConstraints) - flags = fromMaybe [] (Map.lookup name flagsConstraints) - PackagePreferences pref _ = preferences name ] - where - versionConstraints = Map.fromListWith intersectVersionRanges - [ (name, versionRange) - | PackageVersionConstraint name versionRange <- constraints ] - - flagsConstraints = Map.fromListWith (++) - [ (name, flags) - | PackageFlagsConstraint name flags <- constraints ] - --- | Gets the best available package satisfying a dependency. --- -latestAvailableSatisfying :: PackageIndex AvailablePackage - -> PackageName -> VersionRange -> VersionRange - -> Maybe AvailablePackage -latestAvailableSatisfying index name versionConstraint versionPreference = - case PackageIndex.lookupDependency index dep of - [] -> Nothing - pkgs -> Just (maximumBy best pkgs) - where - dep = Dependency name versionConstraint - best = comparing (\p -> (isPreferred p, packageVersion p)) - isPreferred p = packageVersion p `withinRange` versionPreference diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs +++ /dev/null @@ -1,776 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, PackageConstraint(..) - , PackagePreferences(..), InstalledPreference(..) - , Progress(..), foldProgress ) - -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Package - ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName - , Dependency(Dependency), thisPackageVersion, notThisPackageVersion - , PackageFixedDeps(depends) ) -import Distribution.PackageDescription - ( PackageDescription(buildDepends) ) -import Distribution.Client.PackageUtils - ( externalBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, flattenPackageDescription ) -import Distribution.Version - ( VersionRange, anyVersion, withinRange, simplifyVersionRange - , UpperBound(..), asVersionIntervals ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils - ( equating, comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) -import Data.Maybe - ( fromJust, fromMaybe, catMaybes ) -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 -import Control.Exception - ( assert ) - --- ------------------------------------------------------------ --- * Search state types --- ------------------------------------------------------------ - -type Constraints = Constraints.Constraints - InstalledPackageEx 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 -> PackagePreferences) - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage - -> Progress Log Failure (SelectedPackages, Constraints) - -explore _ (Failure failure) = Fail failure -explore _ (ChoiceNode (s,c,_) []) = Done (s,c) -explore pref (ChoiceNode _ choices) = - case [ choice | [choice] <- choices ] of - ((_, node'):_) -> Step (logInfo node') (explore pref node') - [] -> Step (logInfo node') (explore pref node') - where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (_, node') = maximumBy (bestByPref pkgname) choice - where - topSortNumber choice = case fst (head choice) of - InstalledOnly (InstalledPackageEx _ i _) -> i - AvailableOnly (UnconfiguredPackage _ i _) -> i - InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i - - bestByPref pkgname = case packageInstalledPreference of - PreferLatest -> - comparing (\(p,_) -> ( isPreferred p, packageId p)) - PreferInstalled -> - comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) - where - isInstalled (AvailableOnly _) = False - isInstalled _ = True - isPreferred p = packageVersion p `withinRange` preferredVersions - (PackagePreferences preferredVersions packageInstalledPreference) - = pref pkgname - - logInfo node = Select selected discarded - where (selected, discarded) = case node of - Failure _ -> ([], []) - ChoiceNode (_,_,changes) _ -> changes - --- ------------------------------------------------------------ --- * Generate a search tree --- ------------------------------------------------------------ - -type ConfigurePackage = PackageIndex SelectablePackage - -> SelectablePackage - -> Either [Dependency] SelectedPackage - --- | (packages selected, packages discarded) -type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) - -searchSpace :: ConfigurePackage - -> Constraints - -> SelectedPackages - -> SelectionChanges - -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage -searchSpace configure constraints selected changes next = - ChoiceNode (selected, constraints, changes) - [ [ (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' -> case constrainDeps pkg' newDeps constraints [] of - Left failure -> Failure failure - Right (constraints', newDiscarded) -> - searchSpace configure - constraints' selected' (newSelected, newDiscarded) next' - where - selected' = foldl' (flip PackageIndex.insert) selected newSelected - newSelected = - case Constraints.isPaired constraints (packageId pkg) of - Nothing -> [pkg'] - Just pkgid' -> [pkg', pkg''] - where - Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) - (PackageIndex.lookupPackageId available pkgid') - - newPkgs = [ name' - | dep <- newDeps - , let (Dependency name' _) = untagDependency dep - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = concatMap packageConstraints newSelected - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - -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 (InstalledPackageEx _ _ deps) = - [ TaggedDependency InstalledConstraint (thisPackageVersion dep) - | dep <- deps ] - availableConstraints (SemiConfiguredPackage _ _ deps) = - [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] - -constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints - -> [PackageIdentifier] - -> Either Failure (Constraints, [PackageIdentifier]) -constrainDeps pkg [] cs discard = - case addPackageSelectConstraint (packageId pkg) cs of - Satisfiable cs' discard' -> Right (cs', discard' ++ discard) - _ -> impossible -constrainDeps pkg (dep:deps) cs discard = - case addPackageDependencyConstraint (packageId pkg) dep cs of - Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) - Unsatisfiable -> impossible - ConflictsWith conflicts -> - Left (DependencyConflict pkg dep conflicts) - --- ------------------------------------------------------------ --- * The main algorithm --- ------------------------------------------------------------ - -search :: ConfigurePackage - -> (PackageName -> PackagePreferences) - -> 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' :: Platform -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> Progress Log Failure [PlanPackage] -topDownResolver' platform comp installed available - preferences constraints targets = - fmap (uncurry finalise) - . (\cs -> search configure preferences cs initialPkgNames) - =<< addTopLevelConstraints constraints constraintSet - - where - configure = configurePackage platform comp - constraintSet :: Constraints - constraintSet = Constraints.empty - (annotateInstalledPackages topSortNumber installed') - (annotateAvailablePackages constraints topSortNumber available') - (installed', available') = selectNeededSubset installed available - initialPkgNames - topSortNumber = topologicalSortNumbering installed' available' - - initialPkgNames = Set.fromList targets - - finalise selected' constraints' = - PackageIndex.allPackages - . fst . improvePlan installed' constraints' - . PackageIndex.fromList - $ finaliseSelectedPackages preferences selected' constraints' - -addTopLevelConstraints :: [PackageConstraint] -> Constraints - -> Progress a Failure Constraints -addTopLevelConstraints [] cs = Done cs -addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs = - addTopLevelConstraints deps cs - -addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs = - case addTopLevelVersionConstraint pkg ver cs of - Satisfiable cs' _ -> - addTopLevelConstraints deps cs' - - Unsatisfiable -> - Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) - - ConflictsWith conflicts -> - Fail (TopLevelVersionConstraintConflict pkg ver conflicts) - -addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs = - case addTopLevelInstalledConstraint pkg cs of - Satisfiable cs' _ -> addTopLevelConstraints deps cs' - - Unsatisfiable -> - Fail (TopLevelInstallConstraintUnsatisfiable pkg) - - ConflictsWith conflicts -> - Fail (TopLevelInstallConstraintConflict pkg conflicts) - -configurePackage :: Platform -> CompilerId -> ConfigurePackage -configurePackage platform 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 dependencySatisfiable - platform comp [] p of - Left missing -> Left missing - Right (pkg, flags') -> Right $ - SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) - - dependencySatisfiable = not . null . PackageIndex.lookupDependency available - --- | Annotate each installed packages with its set of transative dependencies --- and its topological sort number. --- -annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) - -> PackageIndex InstalledPackage - -> PackageIndex InstalledPackageEx -annotateInstalledPackages dfsNumber installed = PackageIndex.fromList - [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) - | pkg <- PackageIndex.allPackages installed ] - where - transitiveDepends :: InstalledPackage -> [PackageIdentifier] - transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph - . fromJust . toVertex . packageId - (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed - - --- | Annotate each available packages with its topological sort number and any --- user-supplied partial flag assignment. --- -annotateAvailablePackages :: [PackageConstraint] - -> (PackageName -> TopologicalSortNumber) - -> PackageIndex AvailablePackage - -> PackageIndex UnconfiguredPackage -annotateAvailablePackages constraints 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) - | PackageFlagsConstraint name flags <- constraints ] - --- | 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 InstalledPackage - -> 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 InstalledPackage - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,PackageIndex AvailablePackage) -selectNeededSubset installed available = select mempty mempty - where - select :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,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 = -- we filter out packages already included in the indexes - -- this avoids an infinite loop if a package depends on itself - -- like base-3.0.3.0 with base-4.0.0.0 - filter notAlreadyIncluded - $ [ packageName dep - | pkg <- moreInstalled - , dep <- depends pkg ] - ++ [ name - | AvailablePackage _ pkg _ <- moreAvailable - , Dependency name _ <- - buildDepends (flattenPackageDescription pkg) ] - installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled - available'' = foldl' (flip PackageIndex.insert) available' moreAvailable - remaining'' = foldl' (flip Set.insert) remaining' moreRemaining - notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name) - && null (PackageIndex.lookupPackageName available' name) - --- ------------------------------------------------------------ --- * Post processing the solution --- ------------------------------------------------------------ - -finaliseSelectedPackages :: (PackageName -> PackagePreferences) - -> SelectedPackages - -> Constraints - -> [PlanPackage] -finaliseSelectedPackages pref selected constraints = - map finaliseSelected (PackageIndex.allPackages selected) - where - remainingChoices = Constraints.choices constraints - finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg - finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing 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 (Just ipkg) apkg - - finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg - finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = - InstallPlan.Configured (ConfiguredPackage pkg flags deps') - where - deps' = map (packageId . pickRemaining mipkg) deps - - pickRemaining mipkg dep@(Dependency _name versionRange) = - case PackageIndex.lookupDependency remainingChoices dep of - [] -> impossible - [pkg'] -> pkg' - remaining -> assert (checkIsPaired remaining) - $ maximumBy bestByPref remaining - where - -- We order candidate packages to pick for a dependency by these - -- three factors. The last factor is just highest version wins. - bestByPref = - comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) - -- Is the package already used by the installed version of this - -- package? If so we should pick that first. This stops us from doing - -- silly things like deciding to rebuild haskell98 against base 3. - isCurrent = case mipkg :: Maybe InstalledPackageEx of - Nothing -> \_ -> False - Just ipkg -> \p -> packageId p `elem` depends ipkg - -- If there is no upper bound on the version range then we apply a - -- preferred version acording to the hackage or user's suggested - -- version constraints. TODO: distinguish hacks from prefs - bounded = boundedAbove versionRange - isPreferred p - | bounded = True -- any constant will do - | otherwise = packageVersion p `withinRange` preferredVersions - where (PackagePreferences preferredVersions _) = pref (packageName p) - - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of - (_, UpperBound _ _) -> True - (_, NoUpperBound ) -> False - - -- We really only expect to find more than one choice remaining when - -- we're finalising a dependency on a paired package. - checkIsPaired [p1, p2] = - case Constraints.isPaired constraints (packageId p1) of - Just p2' -> packageId p2' == packageId p2 - Nothing -> False - checkIsPaired _ = False - --- | Improve an existing installation plan by, where possible, swapping --- packages we plan to install with ones that are already installed. --- This may add additional constraints due to the dependencies of installed --- packages on other installed packages. --- -improvePlan :: PackageIndex InstalledPackage - -> Constraints - -> PackageIndex PlanPackage - -> (PackageIndex PlanPackage, Constraints) -improvePlan installed constraints0 selected0 = - foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) - where - improve (selected, constraints) = fromMaybe (selected, constraints) - . improvePkg selected constraints - - -- 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 constraints pkgid = do - Configured pkg <- PackageIndex.lookupPackageId selected pkgid - ipkg <- PackageIndex.lookupPackageId installed pkgid - guard $ all (isInstalled selected) (depends pkg) - tryInstalled selected constraints [ipkg] - - isInstalled selected pkgid = - case PackageIndex.lookupPackageId selected pkgid of - Just (PreExisting _) -> True - _ -> False - - tryInstalled :: PackageIndex PlanPackage -> Constraints - -> [InstalledPackage] - -> Maybe (PackageIndex PlanPackage, Constraints) - tryInstalled selected constraints [] = Just (selected, constraints) - tryInstalled selected constraints (pkg:pkgs) = - case constraintsOk (packageId pkg) (depends pkg) constraints of - Nothing -> Nothing - Just constraints' -> tryInstalled selected' constraints' pkgs' - where - selected' = PackageIndex.insert (PreExisting pkg) selected - pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs - notSelected pkgid = - case (PackageIndex.lookupPackageId installed pkgid - ,PackageIndex.lookupPackageId selected pkgid) of - (Just pkg', Nothing) -> Just pkg' - _ -> Nothing - - constraintsOk _ [] constraints = Just constraints - constraintsOk pkgid (pkgid':pkgids) constraints = - case addPackageDependencyConstraint pkgid dep constraints of - Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' - _ -> Nothing - where - dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid') - - reverseTopologicalOrder :: PackageFixedDeps pkg - => PackageIndex pkg -> [PackageIdentifier] - reverseTopologicalOrder index = map (packageId . toPkg) - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkg, _) = PackageIndex.dependencyGraph index - --- ------------------------------------------------------------ --- * Adding and recording constraints --- ------------------------------------------------------------ - -addPackageSelectConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageSelectConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) - reason = SelectedOther pkgid - -addPackageExcludeConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageExcludeConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint - (notThisPackageVersion pkgid) - reason = ExcludedByConfigureFail - -addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageDependencyConstraint pkgid dep constraints = - Constraints.constrain dep reason constraints - where - reason = ExcludedByPackageDependency pkgid dep - -addTopLevelVersionConstraint :: PackageName -> VersionRange - -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addTopLevelVersionConstraint pkg ver constraints = - Constraints.constrain taggedDep reason constraints - where - dep = Dependency pkg ver - taggedDep = TaggedDependency NoInstalledConstraint dep - reason = ExcludedByTopLevelDependency dep - -addTopLevelInstalledConstraint :: PackageName - -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addTopLevelInstalledConstraint pkg constraints = - Constraints.constrain taggedDep reason constraints - where - dep = Dependency pkg anyVersion - taggedDep = TaggedDependency InstalledConstraint 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 " ++ displayDep (untagDependency dep) -showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = - display pkgid ++ " was excluded because of the top level dependency " ++ - displayDep dep - - --- ------------------------------------------------------------ --- * Logging progress and failures --- ------------------------------------------------------------ - -data Log = Select [SelectedPackage] [PackageIdentifier] -data Failure - = ConfigureFailed - SelectablePackage - [(Dependency, [(PackageIdentifier, [ExclusionReason])])] - | DependencyConflict - SelectedPackage TaggedDependency - [(PackageIdentifier, [ExclusionReason])] - | TopLevelVersionConstraintConflict - PackageName VersionRange - [(PackageIdentifier, [ExclusionReason])] - | TopLevelVersionConstraintUnsatisfiable - PackageName VersionRange - | TopLevelInstallConstraintConflict - PackageName - [(PackageIdentifier, [ExclusionReason])] - | TopLevelInstallConstraintUnsatisfiable - PackageName - -showLog :: Log -> String -showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of - ("", y) -> y - (x, "") -> x - (x, y) -> x ++ " and " ++ y - - where - selectedMsg = "selecting " ++ case selected of - [] -> "" - [s] -> display (packageId s) ++ " " ++ kind s - (s:ss) -> listOf id - $ (display (packageId s) ++ " " ++ kind s) - : [ display (packageVersion s') ++ " " ++ kind s' - | s' <- ss ] - - kind (InstalledOnly _) = "(installed)" - kind (AvailableOnly _) = "(hackage)" - kind (InstalledAndAvailable _ _) = "(installed or hackage)" - - discardedMsg = case discarded of - [] -> "" - _ -> "discarding " ++ listOf id - [ element - | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) - , element <- display pkgid : map (display . packageVersion) pkgids ] - -showFailure :: Failure -> String -showFailure (ConfigureFailed pkg missingDeps) = - "cannot configure " ++ displayPkg pkg ++ ". It requires " - ++ listOf (displayDep . fst) missingDeps - ++ '\n' : unlines (map (uncurry whyNot) missingDeps) - - where - whyNot (Dependency name ver) [] = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - - whyNot dep conflicts = - "For the dependency on " ++ displayDep 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 " ++ displayDep dep ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintConflict name ver conflicts) = - "constraints conflict: " - ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - -showFailure (TopLevelInstallConstraintConflict name conflicts) = - "constraints conflict: " - ++ "top level constraint " ++ display name ++ "-installed however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelInstallConstraintUnsatisfiable name) = - "There is no installed version of " ++ display name - -displayVer :: VersionRange -> String -displayVer = display . simplifyVersionRange - -displayDep :: Dependency -> String -displayDep = display . simplifyDependency - -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range) = - Dependency name (simplifyVersionRange range) - --- ------------------------------------------------------------ --- * 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/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs +++ /dev/null @@ -1,316 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, - isPaired, - - constrain, - Satisfiable(..), - conflicting, - ) where - -import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Package - ( PackageName, PackageIdentifier(..) - , Package(packageId), packageName, packageVersion - , PackageFixedDeps(depends) - , Dependency(Dependency) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) - -import Data.List - ( foldl' ) -import Data.Monoid - ( Monoid(mempty) ) -import Data.Maybe - ( catMaybes ) -import qualified Data.Map as Map -import Data.Map (Map) -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)) - - -- Paired choices - (Map PackageName (Version, Version)) - - -- Choices that we have excluded for some reason - -- usually by applying constraints - (PackageIndex (ExcludedPackage PackageIdentifier reason)) - - -- Purely for the invariant, we keep a copy of the original index - (PackageIndex (InstalledOrAvailable installed available)) - - -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 - --- | There is a conservation of packages property. Packages are never gained or --- lost, they just transfer from the remaining pot to the excluded pot. --- -invariant :: (Package installed, Package available) - => Constraints installed available a -> Bool -invariant (Constraints available _ excluded original) = all check merged - where - merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) - (PackageIndex.allPackages original) - (mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages excluded)) - where - mergedPackageId (OnlyInLeft p ) = packageId p - mergedPackageId (OnlyInRight p) = packageId p - mergedPackageId (InBoth p _) = packageId p - - check (InBoth (InstalledOnly _) cur) = case cur of - -- If the package was originally installed only then - -- now it's either still remaining as installed only - -- or it has been excluded in which case we excluded both - -- installed and available since it was only installed - OnlyInLeft (InstalledOnly _) -> True - OnlyInRight (ExcludedPackage _ [] (_:_)) -> True - _ -> False - - check (InBoth (AvailableOnly _) cur) = case cur of - -- If the package was originally available only then - -- now it's either still remaining as available only - -- or it has been excluded in which case we excluded both - -- installed and available since it was only available - OnlyInLeft (AvailableOnly _) -> True - OnlyInRight (ExcludedPackage _ [] (_:_)) -> True - _ -> True - - -- If the package was originally installed and available - -- then there are three cases. - check (InBoth (InstalledAndAvailable _ _) cur) = case cur of - -- We can have both remaining: - OnlyInLeft (InstalledAndAvailable _ _) -> True - -- both excluded, in particular it can have had the available excluded - -- and later had both excluded so we do not mind if the available excluded - -- is empty or non-empty. - OnlyInRight (ExcludedPackage _ _ (_:_)) -> True - -- the installed remaining and the available excluded: - InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True - _ -> False - - check _ = 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 ] - ++ [ pkg | InBoth (ExcludedPackage _ (_:_) []) - pkg@(ExcludedPackage _ (_:_) (_:_)) - <- excludedChange ] - availableChange = mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages available') - excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages excluded) - (PackageIndex.allPackages excluded') - --- | We construct 'Constraints' with an initial 'PackageIndex' of all the --- packages available. --- -empty :: (PackageFixedDeps installed, Package available) - => PackageIndex installed - -> PackageIndex available - -> Constraints installed available reason -empty installed available = Constraints pkgs pairs mempty pkgs - where - pkgs = PackageIndex.fromList - . map toInstalledOrAvailable - $ mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages installed) - (PackageIndex.allPackages available) - toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i - toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a - toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a - - -- pick up cases like base-3 and 4 where one version depends on the other: - pairs = Map.fromList - [ (name, (packageVersion pkgid1, packageVersion pkgid2)) - | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed - , let name = packageName pkg1 - pkgid1 = packageId pkg1 - pkgid2 = packageId pkg2 - , any ((pkgid1==) . packageId) (depends pkg2) - || any ((pkgid2==) . packageId) (depends pkg1) ] - --- | The package choices that are still available. --- -choices :: (Package installed, Package available) - => Constraints installed available reason - -> PackageIndex (InstalledOrAvailable installed available) -choices (Constraints available _ _ _) = available - -isPaired :: (Package installed, Package available) - => Constraints installed available reason - -> PackageIdentifier -> Maybe PackageIdentifier -isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) = - case Map.lookup name pairs of - Just (v1, v2) - | version == v1 -> Just (PackageIdentifier name v2) - | version == v2 -> Just (PackageIdentifier name v1) - _ -> Nothing - -data Satisfiable constraints discarded reason - = Satisfiable constraints discarded - | Unsatisfiable - | ConflictsWith [(PackageIdentifier, [reason])] - -constrain :: (Package installed, Package available) - => TaggedDependency - -> reason - -> Constraints installed available reason - -> Satisfiable (Constraints installed available reason) - [PackageIdentifier] reason -constrain (TaggedDependency installedConstraint (Dependency name versionRange)) - reason constraints@(Constraints available paired excluded original) - - | not anyRemaining - = if null conflicts then Unsatisfiable - else ConflictsWith conflicts - - | otherwise - = let constraints' = Constraints available' paired excluded' original - in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' (map packageId newExcluded) - - 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 _ -> 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' = foldl' (flip PackageIndex.insert) excluded - (newExcluded ++ oldExcluded) - - newExcluded = catMaybes (map exclude availableChoices) where - exclude pkg - | not (satisfiesVersionConstraint pkg) - = Just (ExcludedPackage pkgid [] [reason]) - | installedConstraint == NoInstalledConstraint - = Nothing - | otherwise = case pkg of - InstalledOnly _ -> Nothing - AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason]) - InstalledAndAvailable _ _ -> - case PackageIndex.lookupPackageId excluded pkgid of - Just (ExcludedPackage _ avail both) - -> Just (ExcludedPackage pkgid (reason:avail) both) - Nothing -> Just (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. - oldExcluded = catMaybes (map 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) - = Just (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 - = Just (ExcludedPackage pkgid (reason:avail) both) - | otherwise = Nothing - - -- util definitions - availableChoices = PackageIndex.lookupPackageName available name - excludedChoices = PackageIndex.lookupPackageName excluded name - - satisfiesConstraint pkg = satisfiesVersionConstraint pkg - && satisfiesInstallStateConstraint pkg - - satisfiesVersionConstraint :: Package pkg => pkg -> Bool - satisfiesVersionConstraint = case Map.lookup name paired of - Nothing -> \pkg -> - packageVersion pkg `withinRange` versionRange - Just (v1, v2) -> \pkg -> case packageVersion pkg of - v | v == v1 - || v == v2 -> v1 `withinRange` versionRange - || v2 `withinRange` versionRange - | otherwise -> v `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/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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(..), InstalledPackage ) - -import Distribution.Package - ( PackageIdentifier, Dependency - , Package(packageId), PackageFixedDeps(depends) ) -import Distribution.PackageDescription - ( FlagAssignment ) - --- ------------------------------------------------------------ --- * The various kinds of packages --- ------------------------------------------------------------ - -type SelectablePackage - = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage - -type SelectedPackage - = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage - -data InstalledOrAvailable installed available - = InstalledOnly installed - | AvailableOnly available - | InstalledAndAvailable installed available - -type TopologicalSortNumber = Int - -data InstalledPackageEx - = InstalledPackageEx - InstalledPackage - !TopologicalSortNumber - [PackageIdentifier] -- transative closure of installed deps - -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 InstalledPackageEx where - packageId (InstalledPackageEx p _ _) = packageId p - -instance PackageFixedDeps InstalledPackageEx where - depends (InstalledPackageEx _ _ deps) = deps - -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/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 ( - DependencyResolver, - - PackageConstraint(..), - PackagePreferences(..), - InstalledPreference(..), - - Progress(..), - foldProgress, - ) where - -import Distribution.Client.Types - ( AvailablePackage(..), InstalledPackage ) -import qualified Distribution.Client.InstallPlan as InstallPlan - -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Package - ( PackageName ) -import Distribution.Version - ( VersionRange ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( Platform ) - -import Prelude hiding (fail) - --- | 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 = Platform - -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> Progress String String [InstallPlan.PlanPackage] - --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageVersionConstraint PackageName VersionRange - | PackageInstalledConstraint PackageName - | PackageFlagsConstraint PackageName FlagAssignment - --- | A per-package preference on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. It consists of --- a 'InstalledPreference' which says if we prefer versions of packages --- that are already installed. It also hase a 'PackageVersionPreference' which --- is a suggested constraint on the version number. The resolver should try to --- use package versions that satisfy the suggested version constraint. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackagePreferences = PackagePreferences VersionRange InstalledPreference - --- | Wether we prefer an installed version of a package or simply the latest --- version. --- -data InstalledPreference = 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/cabal-install-0.8.2/Distribution/Client/Fetch.hs b/cabal-install-0.8.2/Distribution/Client/Fetch.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Fetch.hs +++ /dev/null @@ -1,192 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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(..), AvailablePackageDb(..) - , Repo(..), RemoteRepo(..), LocalRepo(..) ) -import Distribution.Client.Dependency - ( resolveDependenciesWithProgress - , dependencyConstraints, dependencyTargets - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) ) -import Distribution.Client.Dependency.Types - ( foldProgress ) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI ) - -import Distribution.Package - ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration ) -import Distribution.Simple.Utils - ( die, notice, info, debug, setupMessage ) -import Distribution.System - ( buildPlatform ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import qualified Data.Map as Map -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) ) - - --- 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 - downloadURI verbosity uri path - 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 - downloadURI verbosity uri path - 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 info verbosity $ display pkgid ++ " has already been downloaded." - return (packageFile repo pkgid) - else do setupMessage verbosity "Downloading" pkgid - downloadPackage verbosity repo pkgid - --- |Fetch a list of packages and their dependencies. -fetch :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> [UnresolvedDependency] - -> IO () -fetch verbosity packageDBs repos comp conf deps = do - installed <- getInstalledPackages verbosity comp packageDBs conf - AvailablePackageDb available availablePrefs - <- 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 - buildPlatform (compilerId comp) - installed' available - (PackagesPreference PreferLatestForSelected - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ]) - (dependencyConstraints deps') - (dependencyTargets 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 - display (packageName pkgid) - display (packageVersion 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) - ,display (packageName pkgid) - ,display (packageVersion pkgid) - ,display pkgid <.> "tar.gz"] - } -packageURI repo pkgid = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,"package" - ,display pkgid <.> "tar.gz"] - } diff --git a/cabal-install-0.8.2/Distribution/Client/Haddock.hs b/cabal-install-0.8.2/Distribution/Client/Haddock.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Haddock.hs +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Haddock --- Copyright : (c) Andrea Vezzosi 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Interfacing with Haddock --- ------------------------------------------------------------------------------ -module Distribution.Client.Haddock - ( - regenerateHaddockIndex - ) - where - -import Data.Maybe (listToMaybe) -import Data.List (maximumBy) -import Control.Monad (guard) -import System.Directory (createDirectoryIfMissing, doesFileExist, - renameFile) -import System.FilePath ((), splitFileName) -import Distribution.Package (Package(..)) -import Distribution.Simple.Program (haddockProgram, ProgramConfiguration - , rawSystemProgram, requireProgramVersion) -import Distribution.Version (Version(Version), orLaterVersion) -import Distribution.Verbosity (Verbosity) -import Distribution.Text (display) -import Distribution.Client.PackageIndex(PackageIndex, allPackages, - allPackagesByName, fromList) -import Distribution.Simple.Utils - ( comparing, intercalate, debug - , installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo - , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) -import Distribution.Client.Types - ( InstalledPackage(..) ) - -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () -regenerateHaddockIndex verbosity pkgs conf index = do - (paths,warns) <- haddockPackagePaths pkgs' - case warns of - Nothing -> return () - Just m -> debug verbosity m - - (confHaddock, _, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (Version [0,6] [])) conf - - createDirectoryIfMissing True destDir - - withTempDirectory verbosity destDir "htemp" $ \tempDir -> do - - let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir] - ++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) paths - rawSystemProgram verbosity confHaddock flags - renameFile (tempDir "index.html") (tempDir destFile) - installDirectoryContents verbosity tempDir destDir - - where - (destDir,destFile) = splitFileName index - pkgs' = map (maximumBy $ comparing packageId) - . allPackagesByName - . fromList - . filter exposed - . map (\(InstalledPackage pkg _) -> pkg) - . allPackages - $ pkgs - -haddockPackagePaths :: [InstalledPackageInfo] - -> IO ([(FilePath, FilePath)], Maybe [Char]) -haddockPackagePaths pkgs = do - interfaces <- sequence - [ case interfaceAndHtmlPath pkg of - Just (interface, html) -> do - exists <- doesFileExist interface - if exists - then return (pkgid, Just (interface, html)) - else return (pkgid, Nothing) - Nothing -> return (pkgid, Nothing) - | pkg <- pkgs, let pkgid = packageId pkg ] - - let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] - - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map display missing) - - flags = [ x | (_, Just x) <- interfaces ] - - return (flags, if null missing then Nothing else Just warning) - - where - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - guard (not . null $ html) - return (interface, html) diff --git a/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs b/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | Separate module for HTTP actions, using a proxy server if one exists ------------------------------------------------------------------------------ -module Distribution.Client.HttpUtils ( - downloadURI, - getHTTP, - proxy, - isOldHackageURI - ) where - -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..) ) -import Network.URI - ( URI (..), URIAuth (..), parseAbsoluteURI ) -import Network.Stream - ( Result, ConnError(..) ) -import Network.Browser - ( Proxy (..), Authority (..), browse - , setOutHandler, setErrHandler, setProxy, request) -import Control.Monad - ( mplus, join, liftM2 ) -import qualified Data.ByteString.Lazy.Char8 as ByteString -import Data.ByteString.Lazy (ByteString) -#ifdef WIN32 -import System.Win32.Types - ( DWORD, HKEY ) -import System.Win32.Registry - ( hKEY_CURRENT_USER, regOpenKey, regCloseKey - , regQueryValue, regQueryValueEx ) -import Control.Exception - ( bracket ) -import Distribution.Compat.Exception - ( handleIO ) -import Foreign - ( toBool, Storable(peek, sizeOf), castPtr, alloca ) -#endif -import System.Environment (getEnvironment) - -import qualified Paths_cabal_install (version) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils - ( die, info, warn, debug - , copyFileVerbose, writeFileAtomic ) -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, envProxyString, registryProxyString :: IO (Maybe String) -#ifdef WIN32 --- read proxy settings from the windows registry -registryProxyString = handleIO (\_ -> 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 -registryProxyString = return Nothing -#endif - --- read proxy settings by looking for an env var -envProxyString = do - env <- getEnvironment - return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) - -proxyString = liftM2 mplus envProxyString registryProxyString - - --- |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 ---TODO: print info message when we're using a proxy - --- | 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 (fixUserInfo uri) - _ -> Nothing - -fixUserInfo :: URI -> URI -fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } - where - f a@URIAuth{ uriUserInfo = s } = - a{ uriUserInfo = case reverse s of - '@':s' -> reverse s' - _ -> s - } -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 ByteString -mkRequest uri = Request{ rqURI = uri - , rqMethod = GET - , rqHeaders = [Header HdrUserAgent userAgent] - , rqBody = ByteString.empty } - 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 ByteString)) -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) - -downloadURI :: Verbosity - -> URI -- ^ What to download - -> FilePath -- ^ Where to put it - -> IO () -downloadURI verbosity uri path | uriScheme uri == "file:" = - copyFileVerbose verbosity (uriPath uri) path -downloadURI verbosity uri path = do - result <- getHTTP verbosity uri - let result' = case result of - Left err -> Left err - Right rsp -> case rspCode rsp of - (2,0,0) -> Right (rspBody rsp) - (a,b,c) -> Left err - where - err = ErrorMisc $ "Unsucessful HTTP code: " - ++ concatMap show [a,b,c] - - case result' of - Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err - Right body -> do - info verbosity ("Downloaded to " ++ path) - writeFileAtomic path (ByteString.unpack body) - --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. - --- 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/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs b/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs +++ /dev/null @@ -1,301 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 ( - getInstalledPackages, - getAvailablePackages, - - readPackageIndexFile, - readRepoIndex, - parseRepoIndex, - - disambiguatePackageName, - disambiguateDependencies - ) where - -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), RemoteRepo(..) - , AvailablePackageDb(..), InstalledPackage(..) ) - -import Distribution.Package - ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) - , Dependency(Dependency), InstalledPackageId(..) ) -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.PackageIndex as PackageIndex -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.PackageDescription - ( GenericPackageDescription ) -import Distribution.PackageDescription.Parse - ( parsePackageDescription ) -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration ) -import qualified Distribution.Simple.Configure as Configure - ( getInstalledPackages ) -import Distribution.ParseUtils - ( ParseResult(..) ) -import Distribution.Version - ( Version(Version), intersectVersionRanges ) -import Distribution.Text - ( display, simpleParse ) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) - -import Data.Maybe (catMaybes, fromMaybe) -import Data.List (isPrefixOf) -import Data.Monoid (Monoid(..)) -import qualified Data.Map as Map -import Control.Monad (MonadPlus(mplus), when) -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 qualified Codec.Compression.GZip as GZip (decompress) -import System.FilePath ((), takeExtension, splitDirectories, normalise) -import System.FilePath.Posix as FilePath.Posix - ( takeFileName ) -import System.IO.Error (isDoesNotExistError) -import System.Directory - ( getModificationTime ) -import System.Time - ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) - -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramConfiguration - -> IO (Maybe (PackageIndex InstalledPackage)) -getInstalledPackages verbosity comp packageDbs conf = - fmap (fmap convert) - (Configure.getInstalledPackages verbosity comp packageDbs conf) - where - convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage - convert index = PackageIndex.fromList $ - reverse -- because later ones mask earlier ones, but - -- InstalledPackageIndex.allPackages gives us the most preferred - -- instances first, when packages share a package id, like when - -- the same package is installed in the global & user dbs. - [ InstalledPackage ipkg (sourceDeps index ipkg) - | ipkg <- InstalledPackageIndex.allPackages index ] - - -- The InstalledPackageInfo only lists dependencies by the - -- InstalledPackageId, which means we do not directly know the corresponding - -- source dependency. The only way to find out is to lookup the - -- InstalledPackageId to get the InstalledPackageInfo and look at its - -- source PackageId. But if the package is broken because it depends on - -- other packages that do not exist then we have a problem we cannot find - -- the original source package id. Instead we make up a bogus package id. - -- This should have the same effect since it should be a dependency on a - -- non-existant package. - sourceDeps index ipkg = - [ maybe (brokenPackageId depid) packageId mdep - | let depids = InstalledPackageInfo.depends ipkg - getpkg = InstalledPackageIndex.lookupInstalledPackageId index - , (depid, mdep) <- zip depids (map getpkg depids) ] - - brokenPackageId (InstalledPackageId str) = - PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) - --- | Read a repository index from disk, from the local files specified by --- a list of 'Repo's. --- --- All the 'AvailablePackage's are marked as having come from the appropriate --- 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb -getAvailablePackages verbosity [] = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." - return AvailablePackageDb { - packageIndex = mempty, - packagePreferences = mempty - } -getAvailablePackages verbosity repos = do - info verbosity "Reading available packages..." - pkgss <- mapM (readRepoIndex verbosity) repos - let (pkgs, prefs) = mconcat pkgss - prefs' = Map.fromListWith intersectVersionRanges - [ (name, range) | Dependency name range <- prefs ] - _ <- evaluate pkgs - _ <- evaluate prefs' - return AvailablePackageDb { - packageIndex = pkgs, - packagePreferences = prefs' - } - --- | Read a repository index from disk, from the local file specified by --- the 'Repo'. --- --- All the 'AvailablePackage's are marked as having come from the given 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -readRepoIndex :: Verbosity -> Repo - -> IO (PackageIndex AvailablePackage, [Dependency]) -readRepoIndex verbosity repo = handleNotFound $ do - let indexFile = repoLocalDir repo "00-index.tar" - (pkgs, prefs) <- either fail return - . foldlTarball extract ([], []) - =<< BS.readFile indexFile - - pkgIndex <- evaluate $ PackageIndex.fromList - [ AvailablePackage { - packageInfoId = pkgid, - packageDescription = pkg, - packageSource = RepoTarballPackage repo - } - | (pkgid, pkg) <- pkgs] - - warnIfIndexIsOld indexFile - return (pkgIndex, prefs) - - where - extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ - (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) - `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) - - extractPrefs :: Tar.Entry -> Maybe [Dependency] - extractPrefs entry = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeFileName (Tar.entryPath entry) == "preferred-versions" - -> Just . parsePreferredVersions - . BS.Char8.unpack $ content - _ -> Nothing - - 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 - - isOldThreshold = 15 --days - warnIfIndexIsOld indexFile = do - indexTime <- getModificationTime indexFile - currentTime <- getClockTime - let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) - when (tdDay diff >= isOldThreshold) $ case repoKind repo of - Left remoteRepo -> warn verbosity $ - "The package list for '" ++ remoteRepoName remoteRepo - ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " - ++ "'cabal update' to get the latest list of available packages." - Right _localRepo -> return () - -parsePreferredVersions :: String -> [Dependency] -parsePreferredVersions = catMaybes - . map simpleParse - . filter (not . isPrefixOf "--") - . lines - --- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. --- --- This is supposed to be an \"all in one\" way to easily get at the info in --- the hackage package index. --- --- It takes a function to map a 'GenericPackageDescription' into any more --- specific instance of 'Package' that you might want to use. In the simple --- case you can just use @\_ p -> p@ here. --- -readPackageIndexFile :: Package pkg - => (PackageId -> GenericPackageDescription -> pkg) - -> FilePath -> IO (PackageIndex pkg) -readPackageIndexFile mkPkg indexFile = do - pkgs <- either fail return - . parseRepoIndex - . GZip.decompress - =<< BS.readFile indexFile - - evaluate $ PackageIndex.fromList - [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] - --- | Parse an uncompressed \"00-index.tar\" repository index file represented --- as a 'ByteString'. --- -parseRepoIndex :: ByteString - -> Either String [(PackageId, GenericPackageDescription)] -parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] - -extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) -extractPkg entry = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeExtension fileName == ".cabal" - -> case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just (pkgid, descr) - where - pkgid = PackageIdentifier (PackageName pkgname) ver - parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack - $ content - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " - ++ show fileName - _ -> Nothing - _ -> Nothing - _ -> Nothing - where - fileName = Tar.entryPath entry - -foldlTarball :: (a -> Tar.Entry -> a) -> a - -> ByteString -> Either String a -foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read - where - check _ (Tar.Fail err) = Left err - check ok Tar.Done = Right ok - check ok (Tar.Next e es) = check (e:ok) es - --- | 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 " ++ display name ++ ". " - ++ "Perhaps you need to run 'cabal update' first?" - else "The package name " ++ display name ++ "is ambigious. " - ++ "It could be: " ++ intercalate ", " (map display 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 - -> PackageName - -> Either PackageName [PackageName] -disambiguatePackageName index (PackageName 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/cabal-install-0.8.2/Distribution/Client/Init.hs b/cabal-install-0.8.2/Distribution/Client/Init.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Init.hs +++ /dev/null @@ -1,556 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init ( - - -- * Commands - initCabal - - ) where - -import System.IO - ( hSetBuffering, stdout, BufferMode(..) ) -import System.Directory - ( getCurrentDirectory ) -import Data.Time - ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) - -import Data.List - ( intersperse ) -import Data.Maybe - ( fromMaybe, isJust ) -import Data.Traversable - ( traverse ) -import Control.Monad - ( when ) -#if MIN_VERSION_base(3,0,0) -import Control.Monad - ( (>=>) ) -#endif - -import Text.PrettyPrint.HughesPJ hiding (mode, cat) - -import Data.Version - ( Version(..) ) -import Distribution.Version - ( orLaterVersion ) - -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) ) -import Distribution.Client.Init.Licenses - ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) -import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) - -import Distribution.License - ( License(..), knownLicenses ) -import Distribution.ModuleName - ( ) -- for the Text instance - -import Distribution.ReadE - ( runReadE, readP_to_E ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Text - ( display, Text(..) ) - -initCabal :: InitFlags -> IO () -initCabal initFlags = do - hSetBuffering stdout NoBuffering - - initFlags' <- extendFlags initFlags - - writeLicense initFlags' - writeSetupFile initFlags' - success <- writeCabalFile initFlags' - - when success $ generateWarnings initFlags' - ---------------------------------------------------------------------------- --- Flag acquisition ----------------------------------------------------- ---------------------------------------------------------------------------- - --- | Fill in more details by guessing, discovering, or prompting the --- user. -extendFlags :: InitFlags -> IO InitFlags -extendFlags = getPackageName - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getLibOrExec - >=> getSrcDir - >=> getModulesAndBuildTools - --- | Combine two actions which may return a value, preferring the first. That --- is, run the second action only if the first doesn't return a value. -infixr 1 ?>> -(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) -f ?>> g = do - ma <- f - if isJust ma - then return ma - else g - --- | Witness the isomorphism between Maybe and Flag. -maybeToFlag :: Maybe a -> Flag a -maybeToFlag = maybe NoFlag Flag - --- | Get the package name: use the package directory (supplied, or the current --- directory by default) as a guess. -getPackageName :: InitFlags -> IO InitFlags -getPackageName flags = do - guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) - ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) - - pkgName' <- return (flagToMaybe $ packageName flags) - ?>> maybePrompt flags (promptStr "Package name" guess) - ?>> return guess - - return $ flags { packageName = maybeToFlag pkgName' } - --- | Package version: use 0.1 as a last resort, but try prompting the user if --- possible. -getVersion :: InitFlags -> IO InitFlags -getVersion flags = do - let v = Just $ Version { versionBranch = [0,1], versionTags = [] } - v' <- return (flagToMaybe $ version flags) - ?>> maybePrompt flags (prompt "Package version" v) - ?>> return v - return $ flags { version = maybeToFlag v' } - --- | Choose a license. -getLicense :: InitFlags -> IO InitFlags -getLicense flags = do - lic <- return (flagToMaybe $ license flags) - ?>> fmap (fmap (either UnknownLicense id)) - (maybePrompt flags - (promptList "Please choose a license" - knownLicenses (Just BSD3) True)) - return $ flags { license = maybeToFlag lic } - --- | The author's name and email. Prompt, or try to guess from an existing --- darcs repo. -getAuthorInfo :: InitFlags -> IO InitFlags -getAuthorInfo flags = do - (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail - authorName' <- return (flagToMaybe $ author flags) - ?>> maybePrompt flags (promptStr "Author name" authorName) - ?>> return authorName - - authorEmail' <- return (flagToMaybe $ email flags) - ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) - ?>> return authorEmail - - return $ flags { author = maybeToFlag authorName' - , email = maybeToFlag authorEmail' - } - --- | Prompt for a homepage URL. -getHomepage :: InitFlags -> IO InitFlags -getHomepage flags = do - hp <- queryHomepage - hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) - ?>> return hp - - return $ flags { homepage = maybeToFlag hp' } - --- | Right now this does nothing, but it could be changed to do some --- intelligent guessing. -queryHomepage :: IO (Maybe String) -queryHomepage = return Nothing -- get default remote darcs repo? - --- | Prompt for a project synopsis. -getSynopsis :: InitFlags -> IO InitFlags -getSynopsis flags = do - syn <- return (flagToMaybe $ synopsis flags) - ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) - - return $ flags { synopsis = maybeToFlag syn } - --- | Prompt for a package category. --- Note that it should be possible to do some smarter guessing here too, i.e. --- look at the name of the top level source directory. -getCategory :: InitFlags -> IO InitFlags -getCategory flags = do - cat <- return (flagToMaybe $ category flags) - ?>> maybePrompt flags (promptList "Project category" [Codec ..] - Nothing True) - return $ flags { category = maybeToFlag cat } - --- | Ask whether the project builds a library or executable. -getLibOrExec :: InitFlags -> IO InitFlags -getLibOrExec flags = do - isLib <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Library) id `fmap` - (promptList "What does the package build" - [Library, Executable] - Nothing False)) - ?>> return (Just Library) - - return $ flags { packageType = maybeToFlag isLib } - --- | Try to guess the source root directory (don't prompt the user). -getSrcDir :: InitFlags -> IO InitFlags -getSrcDir flags = do - srcDirs <- return (sourceDirs flags) - ?>> guessSourceDirs - - return $ flags { sourceDirs = srcDirs } - --- XXX --- | Try to guess source directories. -guessSourceDirs :: IO (Maybe [String]) -guessSourceDirs = return Nothing - --- | Get the list of exposed modules and extra tools needed to build them. -getModulesAndBuildTools :: InitFlags -> IO InitFlags -getModulesAndBuildTools flags = do - dir <- fromMaybe getCurrentDirectory - (fmap return . flagToMaybe $ packageDir flags) - - -- XXX really should use guessed source roots. - sourceFiles <- scanForModules dir - - mods <- return (exposedModules flags) - ?>> (return . Just . map moduleName $ sourceFiles) - - tools <- return (buildTools flags) - ?>> (return . Just . neededBuildPrograms $ sourceFiles) - - return $ flags { exposedModules = mods - , buildTools = tools } - ---------------------------------------------------------------------------- --- Prompting/user interaction ------------------------------------------- ---------------------------------------------------------------------------- - --- | Run a prompt or not based on the nonInteractive flag of the --- InitFlags structure. -maybePrompt :: InitFlags -> IO t -> IO (Maybe t) -maybePrompt flags p = - case nonInteractive flags of - Flag True -> return Nothing - _ -> Just `fmap` p - --- | Create a prompt with optional default value that returns a --- String. -promptStr :: String -> Maybe String -> IO String -promptStr = promptDefault' Just id - --- | Create a prompt with optional default value that returns a value --- of some Text instance. -prompt :: Text t => String -> Maybe t -> IO t -prompt = promptDefault' - (either (const Nothing) Just . runReadE (readP_to_E id parse)) - display - --- | Create a prompt with an optional default value. -promptDefault' :: (String -> Maybe t) -- ^ parser - -> (t -> String) -- ^ pretty-printer - -> String -- ^ prompt message - -> Maybe t -- ^ optional default value - -> IO t -promptDefault' parser pretty pr def = do - putStr $ mkDefPrompt pr (pretty `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return d - _ -> case parser inp of - Just t -> return t - Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" - promptDefault' parser pretty pr def - --- | Create a prompt from a prompt string and a String representation --- of an optional default value. -mkDefPrompt :: String -> Maybe String -> String -mkDefPrompt pr def = pr ++ defStr def ++ "? " - where defStr Nothing = "" - defStr (Just s) = " [default \"" ++ s ++ "\"]" - --- | Create a prompt from a list of items. -promptList :: (Text t, Eq t) - => String -- ^ prompt - -> [t] -- ^ choices - -> Maybe t -- ^ optional default value - -> Bool -- ^ whether to allow an 'other' option - -> IO (Either String t) -promptList pr choices def other = do - putStrLn $ pr ++ ":" - let options1 = map (\c -> (Just c == def, display c)) choices - options2 = zip ([1..]::[Int]) - (options1 ++ if other then [(False, "Other (specify)")] - else []) - mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 - promptList' (length options2) choices def other - where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest - | otherwise = " " ++ star i ++ rest - where rest = show n ++ ") " - star True = "*" - star False = " " - -promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t) -promptList' numChoices choices def other = do - putStr $ mkDefPrompt "Your choice" (display `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return $ Right d - _ -> case readMaybe inp of - Nothing -> invalidChoice inp - Just n -> getChoice n - where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." - promptList' numChoices choices def other - getChoice n | n < 1 || n > numChoices = invalidChoice (show n) - | n < numChoices || - (n == numChoices && not other) - = return . Right $ choices !! (n-1) - | otherwise = Left `fmap` promptStr "Please specify" Nothing - -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(a,"")] -> Just a - _ -> Nothing - ---------------------------------------------------------------------------- --- File generation ------------------------------------------------------ ---------------------------------------------------------------------------- - -writeLicense :: InitFlags -> IO () -writeLicense flags = do - message flags "Generating LICENSE..." - year <- getYear - let licenseFile = - case license flags of - Flag BSD3 -> Just $ bsd3 (fromMaybe "???" - . flagToMaybe - . author - $ flags) - (show year) - - Flag (GPL (Just (Version {versionBranch = [2]}))) - -> Just gplv2 - - Flag (GPL (Just (Version {versionBranch = [3]}))) - -> Just gplv3 - - Flag (LGPL (Just (Version {versionBranch = [2]}))) - -> Just lgpl2 - - Flag (LGPL (Just (Version {versionBranch = [3]}))) - -> Just lgpl3 - - _ -> Nothing - - case licenseFile of - Just licenseText -> writeFile "LICENSE" licenseText - Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." - -getYear :: IO Integer -getYear = do - u <- getCurrentTime - z <- getCurrentTimeZone - let l = utcToLocalTime z u - (y, _, _) = toGregorian $ localDay l - return y - -writeSetupFile :: InitFlags -> IO () -writeSetupFile flags = do - message flags "Generating Setup.hs..." - writeFile "Setup.hs" setupFile - where - setupFile = unlines - [ "import Distribution.Simple" - , "main = defaultMain" - ] - -writeCabalFile :: InitFlags -> IO Bool -writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do - message flags "Error: no package name provided." - return False -writeCabalFile flags@(InitFlags{packageName = Flag p}) = do - let cabalFileName = p ++ ".cabal" - message flags $ "Generating " ++ cabalFileName ++ "..." - writeFile cabalFileName (generateCabalFile cabalFileName flags) - return True - --- | Generate a .cabal file from an InitFlags structure. NOTE: this --- is rather ad-hoc! What we would REALLY like is to have a --- standard low-level AST type representing .cabal files, which --- preserves things like comments, and to write an *inverse* --- parser/pretty-printer pair between .cabal files and this AST. --- Then instead of this ad-hoc code we could just map an InitFlags --- structure onto a low-level AST structure and use the existing --- pretty-printing code to generate the file. -generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = render $ - (if (minimal c /= Flag True) - then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.") - else empty) - $$ - vcat [ fieldS "Name" (packageName c) - (Just "The name of the package.") - True - - , field "Version" (version c) - (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") - True - - , fieldS "Synopsis" (synopsis c) - (Just "A short (one-line) description of the package.") - True - - , fieldS "Description" NoFlag - (Just "A longer description of the package.") - True - - , fieldS "Homepage" (homepage c) - (Just "URL for the project homepage or repository.") - False - - , fieldS "Bug-reports" NoFlag - (Just "A URL where users can report bugs.") - False - - , field "License" (license c) - (Just "The license under which the package is released.") - True - - , fieldS "License-file" (Flag "LICENSE") - (Just "The file containing the license text.") - True - - , fieldS "Author" (author c) - (Just "The package author(s).") - True - - , fieldS "Maintainer" (email c) - (Just "An email address to which users can send suggestions, bug reports, and patches.") - True - - , fieldS "Copyright" NoFlag - (Just "A copyright notice.") - True - - , fieldS "Category" (either id display `fmap` category c) - Nothing - True - - , fieldS "Build-type" (Flag "Simple") - Nothing - True - - , fieldS "Extra-source-files" NoFlag - (Just "Extra files to be distributed with the package, such as examples or a README.") - True - - , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] [])) - (Just "Constraint on the version of Cabal needed to build this package.") - False - - , case packageType c of - Flag Executable -> - text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat - [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True - - , generateBuildInfo c - ]) - Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat - [ fieldS "Exposed-modules" (listField (exposedModules c)) - (Just "Modules exported by the library.") - True - - , generateBuildInfo c - ]) - _ -> empty - ] - where - generateBuildInfo :: InitFlags -> Doc - generateBuildInfo c' = vcat - [ fieldS "Build-depends" (listField (dependencies c')) - (Just "Packages needed in order to build this package.") - True - - , fieldS "Other-modules" (listField (otherModules c')) - (Just "Modules not exported by this package.") - True - - , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) - (Just "Directories other than the root containing source files.") - False - - , fieldS "Build-tools" (listFieldS (buildTools c')) - (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") - True - ] - - listField :: Text s => Maybe [s] -> Flag String - listField = listFieldS . fmap (map display) - - listFieldS :: Maybe [String] -> Flag String - listFieldS = Flag . maybe "" (concat . intersperse ", ") - - field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc - field s f = fieldS s (fmap display f) - - fieldS :: String -- ^ Name of the field - -> Flag String -- ^ Field contents - -> Maybe String -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Doc - fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty - fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty - fieldS s f com _ = case (isJust com, noComments c, minimal c) of - (_, _, Flag True) -> id - (_, Flag True, _) -> id - (True, _, _) -> (showComment com $$) . ($$ text "") - (False, _, _) -> ($$ text "") - $ - comment f <> text s <> colon - <> text (take (20 - length s) (repeat ' ')) - <> text (fromMaybe "" . flagToMaybe $ f) - comment NoFlag = text "-- " - comment (Flag "") = text "-- " - comment _ = text "" - - showComment :: Maybe String -> Doc - showComment (Just t) = vcat . map text - . map ("-- "++) . lines - . render . fsep . map text . words $ t - showComment Nothing = text "" - --- | Generate warnings for missing fields etc. -generateWarnings :: InitFlags -> IO () -generateWarnings flags = do - message flags "" - when (synopsis flags `elem` [NoFlag, Flag ""]) - (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") - - message flags "You may want to edit the .cabal file and add a Description field." - --- | Possibly generate a message to stdout, taking into account the --- --quiet flag. -message :: InitFlags -> String -> IO () -message (InitFlags{quiet = Flag True}) _ = return () -message _ s = putStrLn s - -#if MIN_VERSION_base(3,0,0) -#else -(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) -f >=> g = \x -> f x >>= g -#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs b/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Heuristics --- Copyright : (c) Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Heuristics ( - guessPackageName, - scanForModules, SourceFileEntry(..), - neededBuildPrograms, - guessAuthorNameMail, - knownCategories, -) where -import Distribution.Simple.Setup(Flag(..)) -import Distribution.ModuleName ( ModuleName, fromString ) -import Distribution.Client.PackageIndex - ( allPackagesByName ) -import qualified Distribution.PackageDescription as PD - ( category, packageDescription ) -import Distribution.Simple.Utils - ( intercalate ) - -import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) ) -import Control.Monad (liftM ) -import Data.Char ( isUpper, isLower, isSpace ) -#if MIN_VERSION_base(3,0,3) -import Data.Either ( partitionEithers ) -#endif -import Data.Maybe ( catMaybes ) -import Data.Monoid ( mempty, mappend ) -import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, - getHomeDirectory, canonicalizePath ) -import System.Environment ( getEnvironment ) -import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), splitDirectories, makeRelative ) - --- |Guess the package name based on the given root directory -guessPackageName :: FilePath -> IO String -guessPackageName = liftM (last . splitDirectories) . canonicalizePath - --- |Data type of source files found in the working directory -data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - } deriving Show - --- |Search for source files in the given directory --- and return pairs of guessed haskell source path and --- module names. -scanForModules :: FilePath -> IO [SourceFileEntry] -scanForModules rootDir = scanForModulesIn rootDir rootDir - -scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] -scanForModulesIn projectRoot srcRoot = scan srcRoot [] - where - scan dir hierarchy = do - entries <- getDirectoryContents (projectRoot dir) - (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) - let modules = catMaybes [ guessModuleName hierarchy file | file <- files ] - recMods <- mapM (scanRecursive dir hierarchy) dirs - return $ concat (modules : recMods) - tagIsDir parent entry = do - isDir <- doesDirectoryExist (parent entry) - return $ (if isDir then Right else Left) entry - guessModuleName hierarchy entry - | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext - | otherwise = Nothing - where - relRoot = makeRelative projectRoot srcRoot - unqualModName = dropExtension entry - modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e - scanRecursive parent hierarchy entry - | isUpper (head entry) = scan (parent entry) (entry : hierarchy) - | isLower (head entry) && entry /= "dist" = - scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) - | otherwise = return [] - --- Unfortunately we cannot use the version exported by Distribution.Simple.Program -knownSuffixHandlers :: [(String,String)] -knownSuffixHandlers = - [ ("gc", "greencard") - , ("chs", "chs") - , ("hsc", "hsc2hs") - , ("x", "alex") - , ("y", "happy") - , ("ly", "happy") - , ("cpphs", "cpp") - ] - -sourceExtensions :: [String] -sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers - -neededBuildPrograms :: [SourceFileEntry] -> [String] -neededBuildPrograms entries = - [ handler - | ext <- nubSet (map fileExtension entries) - , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) - ] - --- |Guess author and email -guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = - update (readFromFile authorRepoFile) mempty >>= - update (getAuthorHome >>= readFromFile) >>= - update readFromEnvironment - where - update _ info@(Flag _, Flag _) = return info - update extract info = liftM (`mappend` info) extract -- prefer info - readFromFile file = do - exists <- doesFileExist file - if exists then liftM nameAndMail (readFile file) else return mempty - readFromEnvironment = fmap extractFromEnvironment getEnvironment - extractFromEnvironment env = - let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) - emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) - in darcsEmailEnv `mappend` emailEnv - getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory - authorRepoFile = "_darcs" "prefs" "author" - --- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached -knownCategories :: AvailablePackageDb -> [String] -knownCategories (AvailablePackageDb available _) = nubSet $ - [ cat | pkg <- map head (allPackagesByName available) - , let catList = (PD.category . PD.packageDescription . packageDescription) pkg - , cat <- splitString ',' catList - ] - --- Parse name and email, from darcs pref files or environment variable -nameAndMail :: String -> (Flag String, Flag String) -nameAndMail str - | all isSpace nameOrEmail = mempty - | null erest = (mempty, Flag $ trim nameOrEmail) - | otherwise = (Flag $ trim nameOrEmail, Flag email) - where - (nameOrEmail,erest) = break (== '<') str - (email,_) = break (== '>') (tail erest) - trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse - removeLeadingSpace = dropWhile isSpace - --- split string at given character, and remove whitespaces -splitString :: Char -> String -> [String] -splitString sep str = go str where - go s = if null s' then [] else tok : go rest where - s' = dropWhile (\c -> c == sep || isSpace c) s - (tok,rest) = break (==sep) s' - -nubSet :: (Ord a) => [a] -> [a] -nubSet = Set.toList . Set.fromList - -{- -test db testProjectRoot = do - putStrLn "Guessed package name" - (guessPackageName >=> print) testProjectRoot - putStrLn "Guessed name and email" - guessAuthorNameMail >>= print - - mods <- scanForModules testProjectRoot - - putStrLn "Guessed modules" - mapM_ print mods - putStrLn "Needed build programs" - print (neededBuildPrograms mods) - - putStrLn "List of known categories" - print $ knownCategories db --} - -#if MIN_VERSION_base(3,0,3) -#else -partitionEithers :: [Either a b] -> ([a],[b]) -partitionEithers = foldr (either left right) ([],[]) - where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) -#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs b/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs +++ /dev/null @@ -1,1722 +0,0 @@ -module Distribution.Client.Init.Licenses - ( License - , bsd3 - , gplv2 - , gplv3 - , lgpl2 - , lgpl3 - - ) where - -type License = String - -bsd3 :: String -> String -> License -bsd3 authors year = unlines - [ "Copyright (c)" ++ year ++ ", " ++ authors - , "" - , "All rights reserved." - , "" - , "Redistribution and use in source and binary forms, with or without" - , "modification, are permitted provided that the following conditions are met:" - , "" - , " * Redistributions of source code must retain the above copyright" - , " notice, this list of conditions and the following disclaimer." - , "" - , " * Redistributions in binary form must reproduce the above" - , " copyright notice, this list of conditions and the following" - , " disclaimer in the documentation and/or other materials provided" - , " with the distribution." - , "" - , " * Neither the name of " ++ authors ++ " nor the names of other" - , " contributors may be used to endorse or promote products derived" - , " from this software without specific prior written permission." - , "" - , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" - , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" - , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" - , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" - , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," - , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" - , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," - , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" - , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" - , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" - , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." - ] - -gplv2 :: License -gplv2 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "License is intended to guarantee your freedom to share and change free" - , "software--to make sure the software is free for all its users. This" - , "General Public License applies to most of the Free Software" - , "Foundation's software and to any other program whose authors commit to" - , "using it. (Some other Free Software Foundation software is covered by" - , "the GNU Lesser General Public License instead.) You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if you" - , "distribute copies of the software, or if you modify it." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must give the recipients all the rights that" - , "you have. You must make sure that they, too, receive or can get the" - , "source code. And you must show them these terms so they know their" - , "rights." - , "" - , " We protect your rights with two steps: (1) copyright the software, and" - , "(2) offer you this license which gives you legal permission to copy," - , "distribute and/or modify the software." - , "" - , " Also, for each author's protection and ours, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "software. If the software is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original, so" - , "that any problems introduced by others will not reflect on the original" - , "authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that redistributors of a free" - , "program will individually obtain patent licenses, in effect making the" - , "program proprietary. To prevent this, we have made it clear that any" - , "patent must be licensed for everyone's free use or not licensed at all." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " GNU GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License applies to any program or other work which contains" - , "a notice placed by the copyright holder saying it may be distributed" - , "under the terms of this General Public License. The \"Program\", below," - , "refers to any such program or work, and a \"work based on the Program\"" - , "means either the Program or any derivative work under copyright law:" - , "that is to say, a work containing the Program or a portion of it," - , "either verbatim or with modifications and/or translated into another" - , "language. (Hereinafter, translation is included without limitation in" - , "the term \"modification\".) Each licensee is addressed as \"you\"." - , "" - , "Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running the Program is not restricted, and the output from the Program" - , "is covered only if its contents constitute a work based on the" - , "Program (independent of having been made by running the Program)." - , "Whether that is true depends on what the Program does." - , "" - , " 1. You may copy and distribute verbatim copies of the Program's" - , "source code as you receive it, in any medium, provided that you" - , "conspicuously and appropriately publish on each copy an appropriate" - , "copyright notice and disclaimer of warranty; keep intact all the" - , "notices that refer to this License and to the absence of any warranty;" - , "and give any other recipients of the Program a copy of this License" - , "along with the Program." - , "" - , "You may charge a fee for the physical act of transferring a copy, and" - , "you may at your option offer warranty protection in exchange for a fee." - , "" - , " 2. You may modify your copy or copies of the Program or any portion" - , "of it, thus forming a work based on the Program, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) You must cause the modified files to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " b) You must cause any work that you distribute or publish, that in" - , " whole or in part contains or is derived from the Program or any" - , " part thereof, to be licensed as a whole at no charge to all third" - , " parties under the terms of this License." - , "" - , " c) If the modified program normally reads commands interactively" - , " when run, you must cause it, when started running for such" - , " interactive use in the most ordinary way, to print or display an" - , " announcement including an appropriate copyright notice and a" - , " notice that there is no warranty (or else, saying that you provide" - , " a warranty) and that users may redistribute the program under" - , " these conditions, and telling the user how to view a copy of this" - , " License. (Exception: if the Program itself is interactive but" - , " does not normally print such an announcement, your work based on" - , " the Program is not required to print an announcement.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Program," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Program, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Program." - , "" - , "In addition, mere aggregation of another work not based on the Program" - , "with the Program (or with a work based on the Program) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may copy and distribute the Program (or a work based on it," - , "under Section 2) in object code or executable form under the terms of" - , "Sections 1 and 2 above provided that you also do one of the following:" - , "" - , " a) Accompany it with the complete corresponding machine-readable" - , " source code, which must be distributed under the terms of Sections" - , " 1 and 2 above on a medium customarily used for software interchange; or," - , "" - , " b) Accompany it with a written offer, valid for at least three" - , " years, to give any third party, for a charge no more than your" - , " cost of physically performing source distribution, a complete" - , " machine-readable copy of the corresponding source code, to be" - , " distributed under the terms of Sections 1 and 2 above on a medium" - , " customarily used for software interchange; or," - , "" - , " c) Accompany it with the information you received as to the offer" - , " to distribute corresponding source code. (This alternative is" - , " allowed only for noncommercial distribution and only if you" - , " received the program in object code or executable form with such" - , " an offer, in accord with Subsection b above.)" - , "" - , "The source code for a work means the preferred form of the work for" - , "making modifications to it. For an executable work, complete source" - , "code means all the source code for all modules it contains, plus any" - , "associated interface definition files, plus the scripts used to" - , "control compilation and installation of the executable. However, as a" - , "special exception, the source code distributed need not include" - , "anything that is normally distributed (in either source or binary" - , "form) with the major components (compiler, kernel, and so on) of the" - , "operating system on which the executable runs, unless that component" - , "itself accompanies the executable." - , "" - , "If distribution of executable or object code is made by offering" - , "access to copy from a designated place, then offering equivalent" - , "access to copy the source code from the same place counts as" - , "distribution of the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 4. You may not copy, modify, sublicense, or distribute the Program" - , "except as expressly provided under this License. Any attempt" - , "otherwise to copy, modify, sublicense or distribute the Program is" - , "void, and will automatically terminate your rights under this License." - , "However, parties who have received copies, or rights, from you under" - , "this License will not have their licenses terminated so long as such" - , "parties remain in full compliance." - , "" - , " 5. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Program or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Program (or any work based on the" - , "Program), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Program or works based on it." - , "" - , " 6. Each time you redistribute the Program (or any work based on the" - , "Program), the recipient automatically receives a license from the" - , "original licensor to copy, distribute or modify the Program subject to" - , "these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 7. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Program at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Program by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Program." - , "" - , "If any portion of this section is held invalid or unenforceable under" - , "any particular circumstance, the balance of the section is intended to" - , "apply and the section as a whole is intended to apply in other" - , "circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system, which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 8. If the distribution and/or use of the Program is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Program under this License" - , "may add an explicit geographical distribution limitation excluding" - , "those countries, so that distribution is permitted only in or among" - , "countries not thus excluded. In such case, this License incorporates" - , "the limitation as if written in the body of this License." - , "" - , " 9. The Free Software Foundation may publish revised and/or new versions" - , "of the General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Program" - , "specifies a version number of this License which applies to it and \"any" - , "later version\", you have the option of following the terms and conditions" - , "either of that version or of any later version published by the Free" - , "Software Foundation. If the Program does not specify a version number of" - , "this License, you may choose any version ever published by the Free Software" - , "Foundation." - , "" - , " 10. If you wish to incorporate parts of the Program into other free" - , "programs whose distribution conditions are different, write to the author" - , "to ask for permission. For software which is copyrighted by the Free" - , "Software Foundation, write to the Free Software Foundation; we sometimes" - , "make exceptions for this. Our decision will be guided by the two goals" - , "of preserving the free status of all derivatives of our free software and" - , "of promoting the sharing and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" - , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" - , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" - , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" - , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" - , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" - , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" - , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," - , "REPAIR OR CORRECTION." - , "" - , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" - , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," - , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" - , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" - , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" - , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" - , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" - , "POSSIBILITY OF SUCH DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software; you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation; either version 2 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License along" - , " with this program; if not, write to the Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "If the program is interactive, make it output a short notice like this" - , "when it starts in an interactive mode:" - , "" - , " Gnomovision version 69, Copyright (C) year name of author" - , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, the commands you use may" - , "be called something other than `show w' and `show c'; they could even be" - , "mouse-clicks or menu items--whatever suits your program." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the program, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" - , " `Gnomovision' (which makes passes at compilers) written by James Hacker." - , "" - , " , 1 April 1989" - , " Ty Coon, President of Vice" - , "" - , "This General Public License does not permit incorporating your program into" - , "proprietary programs. If your program is a subroutine library, you may" - , "consider it more useful to permit linking proprietary applications with the" - , "library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License." - ] - -gplv3 :: License -gplv3 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU General Public License is a free, copyleft license for" - , "software and other kinds of works." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "the GNU General Public License is intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users. We, the Free Software Foundation, use the" - , "GNU General Public License for most of our software; it applies also to" - , "any other work released this way by its authors. You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " To protect your rights, we need to prevent others from denying you" - , "these rights or asking you to surrender the rights. Therefore, you have" - , "certain responsibilities if you distribute copies of the software, or if" - , "you modify it: responsibilities to respect the freedom of others." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must pass on to the recipients the same" - , "freedoms that you received. You must make sure that they, too, receive" - , "or can get the source code. And you must show them these terms so they" - , "know their rights." - , "" - , " Developers that use the GNU GPL protect your rights with two steps:" - , "(1) assert copyright on the software, and (2) offer you this License" - , "giving you legal permission to copy, distribute and/or modify it." - , "" - , " For the developers' and authors' protection, the GPL clearly explains" - , "that there is no warranty for this free software. For both users' and" - , "authors' sake, the GPL requires that modified versions be marked as" - , "changed, so that their problems will not be attributed erroneously to" - , "authors of previous versions." - , "" - , " Some devices are designed to deny users access to install or run" - , "modified versions of the software inside them, although the manufacturer" - , "can do so. This is fundamentally incompatible with the aim of" - , "protecting users' freedom to change the software. The systematic" - , "pattern of such abuse occurs in the area of products for individuals to" - , "use, which is precisely where it is most unacceptable. Therefore, we" - , "have designed this version of the GPL to prohibit the practice for those" - , "products. If such problems arise substantially in other domains, we" - , "stand ready to extend this provision to those domains in future versions" - , "of the GPL, as needed to protect the freedom of users." - , "" - , " Finally, every program is threatened constantly by software patents." - , "States should not allow patents to restrict development and use of" - , "software on general-purpose computers, but in those that do, we wish to" - , "avoid the special danger that patents applied to a free program could" - , "make it effectively proprietary. To prevent this, the GPL assures that" - , "patents cannot be used to render the program non-free." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , " " - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , " " - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Use with the GNU Affero General Public License." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU Affero General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the special requirements of the GNU Affero General Public License," - , "section 13, concerning interaction through a network will apply to the" - , "combination as such." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If the program does terminal interaction, make it output a short" - , "notice like this when it starts in an interactive mode:" - , "" - , " Copyright (C) " - , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, your program's commands" - , "might be different; for a GUI interface, you would use an \"about box\"." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU GPL, see" - , "." - , "" - , " The GNU General Public License does not permit incorporating your program" - , "into proprietary programs. If your program is a subroutine library, you" - , "may consider it more useful to permit linking proprietary applications with" - , "the library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License. But first, please read" - , "." - , "" - ] - -lgpl2 :: License -lgpl2 = unlines - [ " GNU LIBRARY GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1991 Free Software Foundation, Inc." - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "[This is the first released version of the library GPL. It is" - , " numbered 2 because it goes with version 2 of the ordinary GPL.]" - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "Licenses are intended to guarantee your freedom to share and change" - , "free software--to make sure the software is free for all its users." - , "" - , " This license, the Library General Public License, applies to some" - , "specially designated Free Software Foundation software, and to any" - , "other libraries whose authors decide to use it. You can use it for" - , "your libraries, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if" - , "you distribute copies of the library, or if you modify it." - , "" - , " For example, if you distribute copies of the library, whether gratis" - , "or for a fee, you must give the recipients all the rights that we gave" - , "you. You must make sure that they, too, receive or can get the source" - , "code. If you link a program with the library, you must provide" - , "complete object files to the recipients so that they can relink them" - , "with the library, after making changes to the library and recompiling" - , "it. And you must show them these terms so they know their rights." - , "" - , " Our method of protecting your rights has two steps: (1) copyright" - , "the library, and (2) offer you this license which gives you legal" - , "permission to copy, distribute and/or modify the library." - , "" - , " Also, for each distributor's protection, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "library. If the library is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original" - , "version, so that any problems introduced by others will not reflect on" - , "the original authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that companies distributing free" - , "software will individually obtain patent licenses, thus in effect" - , "transforming the program into proprietary software. To prevent this," - , "we have made it clear that any patent must be licensed for everyone's" - , "free use or not licensed at all." - , "" - , " Most GNU software, including some libraries, is covered by the ordinary" - , "GNU General Public License, which was designed for utility programs. This" - , "license, the GNU Library General Public License, applies to certain" - , "designated libraries. This license is quite different from the ordinary" - , "one; be sure to read it in full, and don't assume that anything in it is" - , "the same as in the ordinary license." - , "" - , " The reason we have a separate public license for some libraries is that" - , "they blur the distinction we usually make between modifying or adding to a" - , "program and simply using it. Linking a program with a library, without" - , "changing the library, is in some sense simply using the library, and is" - , "analogous to running a utility program or application program. However, in" - , "a textual and legal sense, the linked executable is a combined work, a" - , "derivative of the original library, and the ordinary General Public License" - , "treats it as such." - , "" - , " Because of this blurred distinction, using the ordinary General" - , "Public License for libraries did not effectively promote software" - , "sharing, because most developers did not use the libraries. We" - , "concluded that weaker conditions might promote sharing better." - , "" - , " However, unrestricted linking of non-free programs would deprive the" - , "users of those programs of all benefit from the free status of the" - , "libraries themselves. This Library General Public License is intended to" - , "permit developers of non-free programs to use free libraries, while" - , "preserving your freedom as a user of such programs to change the free" - , "libraries that are incorporated in them. (We have not seen how to achieve" - , "this as regards changes in header files, but we have achieved it as regards" - , "changes in the actual functions of the Library.) The hope is that this" - , "will lead to faster development of free libraries." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow. Pay close attention to the difference between a" - , "\"work based on the library\" and a \"work that uses the library\". The" - , "former contains code derived from the library, while the latter only" - , "works together with the library." - , "" - , " Note that it is possible for a library to be covered by the ordinary" - , "General Public License rather than by this special one." - , "" - , " GNU LIBRARY GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License Agreement applies to any software library which" - , "contains a notice placed by the copyright holder or other authorized" - , "party saying it may be distributed under the terms of this Library" - , "General Public License (also called \"this License\"). Each licensee is" - , "addressed as \"you\"." - , "" - , " A \"library\" means a collection of software functions and/or data" - , "prepared so as to be conveniently linked with application programs" - , "(which use some of those functions and data) to form executables." - , "" - , " The \"Library\", below, refers to any such software library or work" - , "which has been distributed under these terms. A \"work based on the" - , "Library\" means either the Library or any derivative work under" - , "copyright law: that is to say, a work containing the Library or a" - , "portion of it, either verbatim or with modifications and/or translated" - , "straightforwardly into another language. (Hereinafter, translation is" - , "included without limitation in the term \"modification\".)" - , "" - , " \"Source code\" for a work means the preferred form of the work for" - , "making modifications to it. For a library, complete source code means" - , "all the source code for all modules it contains, plus any associated" - , "interface definition files, plus the scripts used to control compilation" - , "and installation of the library." - , "" - , " Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running a program using the Library is not restricted, and output from" - , "such a program is covered only if its contents constitute a work based" - , "on the Library (independent of the use of the Library in a tool for" - , "writing it). Whether that is true depends on what the Library does" - , "and what the program that uses the Library does." - , " " - , " 1. You may copy and distribute verbatim copies of the Library's" - , "complete source code as you receive it, in any medium, provided that" - , "you conspicuously and appropriately publish on each copy an" - , "appropriate copyright notice and disclaimer of warranty; keep intact" - , "all the notices that refer to this License and to the absence of any" - , "warranty; and distribute a copy of this License along with the" - , "Library." - , "" - , " You may charge a fee for the physical act of transferring a copy," - , "and you may at your option offer warranty protection in exchange for a" - , "fee." - , "" - , " 2. You may modify your copy or copies of the Library or any portion" - , "of it, thus forming a work based on the Library, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) The modified work must itself be a software library." - , "" - , " b) You must cause the files modified to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " c) You must cause the whole of the work to be licensed at no" - , " charge to all third parties under the terms of this License." - , "" - , " d) If a facility in the modified Library refers to a function or a" - , " table of data to be supplied by an application program that uses" - , " the facility, other than as an argument passed when the facility" - , " is invoked, then you must make a good faith effort to ensure that," - , " in the event an application does not supply such function or" - , " table, the facility still operates, and performs whatever part of" - , " its purpose remains meaningful." - , "" - , " (For example, a function in a library to compute square roots has" - , " a purpose that is entirely well-defined independent of the" - , " application. Therefore, Subsection 2d requires that any" - , " application-supplied function or table used by this function must" - , " be optional: if the application does not supply it, the square" - , " root function must still compute square roots.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Library," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Library, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote" - , "it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Library." - , "" - , "In addition, mere aggregation of another work not based on the Library" - , "with the Library (or with a work based on the Library) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may opt to apply the terms of the ordinary GNU General Public" - , "License instead of this License to a given copy of the Library. To do" - , "this, you must alter all the notices that refer to this License, so" - , "that they refer to the ordinary GNU General Public License, version 2," - , "instead of to this License. (If a newer version than version 2 of the" - , "ordinary GNU General Public License has appeared, then you can specify" - , "that version instead if you wish.) Do not make any other change in" - , "these notices." - , "" - , " Once this change is made in a given copy, it is irreversible for" - , "that copy, so the ordinary GNU General Public License applies to all" - , "subsequent copies and derivative works made from that copy." - , "" - , " This option is useful when you wish to copy part of the code of" - , "the Library into a program that is not a library." - , "" - , " 4. You may copy and distribute the Library (or a portion or" - , "derivative of it, under Section 2) in object code or executable form" - , "under the terms of Sections 1 and 2 above provided that you accompany" - , "it with the complete corresponding machine-readable source code, which" - , "must be distributed under the terms of Sections 1 and 2 above on a" - , "medium customarily used for software interchange." - , "" - , " If distribution of object code is made by offering access to copy" - , "from a designated place, then offering equivalent access to copy the" - , "source code from the same place satisfies the requirement to" - , "distribute the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 5. A program that contains no derivative of any portion of the" - , "Library, but is designed to work with the Library by being compiled or" - , "linked with it, is called a \"work that uses the Library\". Such a" - , "work, in isolation, is not a derivative work of the Library, and" - , "therefore falls outside the scope of this License." - , "" - , " However, linking a \"work that uses the Library\" with the Library" - , "creates an executable that is a derivative of the Library (because it" - , "contains portions of the Library), rather than a \"work that uses the" - , "library\". The executable is therefore covered by this License." - , "Section 6 states terms for distribution of such executables." - , "" - , " When a \"work that uses the Library\" uses material from a header file" - , "that is part of the Library, the object code for the work may be a" - , "derivative work of the Library even though the source code is not." - , "Whether this is true is especially significant if the work can be" - , "linked without the Library, or if the work is itself a library. The" - , "threshold for this to be true is not precisely defined by law." - , "" - , " If such an object file uses only numerical parameters, data" - , "structure layouts and accessors, and small macros and small inline" - , "functions (ten lines or less in length), then the use of the object" - , "file is unrestricted, regardless of whether it is legally a derivative" - , "work. (Executables containing this object code plus portions of the" - , "Library will still fall under Section 6.)" - , "" - , " Otherwise, if the work is a derivative of the Library, you may" - , "distribute the object code for the work under the terms of Section 6." - , "Any executables containing that work also fall under Section 6," - , "whether or not they are linked directly with the Library itself." - , "" - , " 6. As an exception to the Sections above, you may also compile or" - , "link a \"work that uses the Library\" with the Library to produce a" - , "work containing portions of the Library, and distribute that work" - , "under terms of your choice, provided that the terms permit" - , "modification of the work for the customer's own use and reverse" - , "engineering for debugging such modifications." - , "" - , " You must give prominent notice with each copy of the work that the" - , "Library is used in it and that the Library and its use are covered by" - , "this License. You must supply a copy of this License. If the work" - , "during execution displays copyright notices, you must include the" - , "copyright notice for the Library among them, as well as a reference" - , "directing the user to the copy of this License. Also, you must do one" - , "of these things:" - , "" - , " a) Accompany the work with the complete corresponding" - , " machine-readable source code for the Library including whatever" - , " changes were used in the work (which must be distributed under" - , " Sections 1 and 2 above); and, if the work is an executable linked" - , " with the Library, with the complete machine-readable \"work that" - , " uses the Library\", as object code and/or source code, so that the" - , " user can modify the Library and then relink to produce a modified" - , " executable containing the modified Library. (It is understood" - , " that the user who changes the contents of definitions files in the" - , " Library will not necessarily be able to recompile the application" - , " to use the modified definitions.)" - , "" - , " b) Accompany the work with a written offer, valid for at" - , " least three years, to give the same user the materials" - , " specified in Subsection 6a, above, for a charge no more" - , " than the cost of performing this distribution." - , "" - , " c) If distribution of the work is made by offering access to copy" - , " from a designated place, offer equivalent access to copy the above" - , " specified materials from the same place." - , "" - , " d) Verify that the user has already received a copy of these" - , " materials or that you have already sent this user a copy." - , "" - , " For an executable, the required form of the \"work that uses the" - , "Library\" must include any data and utility programs needed for" - , "reproducing the executable from it. However, as a special exception," - , "the source code distributed need not include anything that is normally" - , "distributed (in either source or binary form) with the major" - , "components (compiler, kernel, and so on) of the operating system on" - , "which the executable runs, unless that component itself accompanies" - , "the executable." - , "" - , " It may happen that this requirement contradicts the license" - , "restrictions of other proprietary libraries that do not normally" - , "accompany the operating system. Such a contradiction means you cannot" - , "use both them and the Library together in an executable that you" - , "distribute." - , "" - , " 7. You may place library facilities that are a work based on the" - , "Library side-by-side in a single library together with other library" - , "facilities not covered by this License, and distribute such a combined" - , "library, provided that the separate distribution of the work based on" - , "the Library and of the other library facilities is otherwise" - , "permitted, and provided that you do these two things:" - , "" - , " a) Accompany the combined library with a copy of the same work" - , " based on the Library, uncombined with any other library" - , " facilities. This must be distributed under the terms of the" - , " Sections above." - , "" - , " b) Give prominent notice with the combined library of the fact" - , " that part of it is a work based on the Library, and explaining" - , " where to find the accompanying uncombined form of the same work." - , "" - , " 8. You may not copy, modify, sublicense, link with, or distribute" - , "the Library except as expressly provided under this License. Any" - , "attempt otherwise to copy, modify, sublicense, link with, or" - , "distribute the Library is void, and will automatically terminate your" - , "rights under this License. However, parties who have received copies," - , "or rights, from you under this License will not have their licenses" - , "terminated so long as such parties remain in full compliance." - , "" - , " 9. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Library or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Library (or any work based on the" - , "Library), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Library or works based on it." - , "" - , " 10. Each time you redistribute the Library (or any work based on the" - , "Library), the recipient automatically receives a license from the" - , "original licensor to copy, distribute, link with or modify the Library" - , "subject to these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 11. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Library at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Library by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Library." - , "" - , "If any portion of this section is held invalid or unenforceable under any" - , "particular circumstance, the balance of the section is intended to apply," - , "and the section as a whole is intended to apply in other circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 12. If the distribution and/or use of the Library is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Library under this License may add" - , "an explicit geographical distribution limitation excluding those countries," - , "so that distribution is permitted only in or among countries not thus" - , "excluded. In such case, this License incorporates the limitation as if" - , "written in the body of this License." - , "" - , " 13. The Free Software Foundation may publish revised and/or new" - , "versions of the Library General Public License from time to time." - , "Such new versions will be similar in spirit to the present version," - , "but may differ in detail to address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Library" - , "specifies a version number of this License which applies to it and" - , "\"any later version\", you have the option of following the terms and" - , "conditions either of that version or of any later version published by" - , "the Free Software Foundation. If the Library does not specify a" - , "license version number, you may choose any version ever published by" - , "the Free Software Foundation." - , "" - , " 14. If you wish to incorporate parts of the Library into other free" - , "programs whose distribution conditions are incompatible with these," - , "write to the author to ask for permission. For software which is" - , "copyrighted by the Free Software Foundation, write to the Free" - , "Software Foundation; we sometimes make exceptions for this. Our" - , "decision will be guided by the two goals of preserving the free status" - , "of all derivatives of our free software and of promoting the sharing" - , "and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" - , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." - , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" - , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" - , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" - , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" - , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" - , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" - , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" - , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" - , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" - , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" - , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" - , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" - , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" - , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" - , "DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Libraries" - , "" - , " If you develop a new library, and you want it to be of the greatest" - , "possible use to the public, we recommend making it free software that" - , "everyone can redistribute and change. You can do so by permitting" - , "redistribution under these terms (or, alternatively, under the terms of the" - , "ordinary General Public License)." - , "" - , " To apply these terms, attach the following notices to the library. It is" - , "safest to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least the" - , "\"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This library is free software; you can redistribute it and/or" - , " modify it under the terms of the GNU Library General Public" - , " License as published by the Free Software Foundation; either" - , " version 2 of the License, or (at your option) any later version." - , "" - , " This library is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - , " Library General Public License for more details." - , "" - , " You should have received a copy of the GNU Library General Public" - , " License along with this library; if not, write to the Free" - , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the library, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" - , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." - , "" - , " , 1 April 1990" - , " Ty Coon, President of Vice" - , "" - , "That's all there is to it!" - ] - -lgpl3 :: License -lgpl3 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "" - , " This version of the GNU Lesser General Public License incorporates" - , "the terms and conditions of version 3 of the GNU General Public" - , "License, supplemented by the additional permissions listed below." - , "" - , " 0. Additional Definitions. " - , "" - , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" - , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" - , "General Public License." - , "" - , " \"The Library\" refers to a covered work governed by this License," - , "other than an Application or a Combined Work as defined below." - , "" - , " An \"Application\" is any work that makes use of an interface provided" - , "by the Library, but which is not otherwise based on the Library." - , "Defining a subclass of a class defined by the Library is deemed a mode" - , "of using an interface provided by the Library." - , "" - , " A \"Combined Work\" is a work produced by combining or linking an" - , "Application with the Library. The particular version of the Library" - , "with which the Combined Work was made is also called the \"Linked" - , "Version\"." - , "" - , " The \"Minimal Corresponding Source\" for a Combined Work means the" - , "Corresponding Source for the Combined Work, excluding any source code" - , "for portions of the Combined Work that, considered in isolation, are" - , "based on the Application, and not on the Linked Version." - , "" - , " The \"Corresponding Application Code\" for a Combined Work means the" - , "object code and/or source code for the Application, including any data" - , "and utility programs needed for reproducing the Combined Work from the" - , "Application, but excluding the System Libraries of the Combined Work." - , "" - , " 1. Exception to Section 3 of the GNU GPL." - , "" - , " You may convey a covered work under sections 3 and 4 of this License" - , "without being bound by section 3 of the GNU GPL." - , "" - , " 2. Conveying Modified Versions." - , "" - , " If you modify a copy of the Library, and, in your modifications, a" - , "facility refers to a function or data to be supplied by an Application" - , "that uses the facility (other than as an argument passed when the" - , "facility is invoked), then you may convey a copy of the modified" - , "version:" - , "" - , " a) under this License, provided that you make a good faith effort to" - , " ensure that, in the event an Application does not supply the" - , " function or data, the facility still operates, and performs" - , " whatever part of its purpose remains meaningful, or" - , "" - , " b) under the GNU GPL, with none of the additional permissions of" - , " this License applicable to that copy." - , "" - , " 3. Object Code Incorporating Material from Library Header Files." - , "" - , " The object code form of an Application may incorporate material from" - , "a header file that is part of the Library. You may convey such object" - , "code under terms of your choice, provided that, if the incorporated" - , "material is not limited to numerical parameters, data structure" - , "layouts and accessors, or small macros, inline functions and templates" - , "(ten or fewer lines in length), you do both of the following:" - , "" - , " a) Give prominent notice with each copy of the object code that the" - , " Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the object code with a copy of the GNU GPL and this license" - , " document." - , "" - , " 4. Combined Works." - , "" - , " You may convey a Combined Work under terms of your choice that," - , "taken together, effectively do not restrict modification of the" - , "portions of the Library contained in the Combined Work and reverse" - , "engineering for debugging such modifications, if you also do each of" - , "the following:" - , "" - , " a) Give prominent notice with each copy of the Combined Work that" - , " the Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" - , " document." - , "" - , " c) For a Combined Work that displays copyright notices during" - , " execution, include the copyright notice for the Library among" - , " these notices, as well as a reference directing the user to the" - , " copies of the GNU GPL and this license document." - , "" - , " d) Do one of the following:" - , "" - , " 0) Convey the Minimal Corresponding Source under the terms of this" - , " License, and the Corresponding Application Code in a form" - , " suitable for, and under terms that permit, the user to" - , " recombine or relink the Application with a modified version of" - , " the Linked Version to produce a modified Combined Work, in the" - , " manner specified by section 6 of the GNU GPL for conveying" - , " Corresponding Source." - , "" - , " 1) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (a) uses at run time" - , " a copy of the Library already present on the user's computer" - , " system, and (b) will operate properly with a modified version" - , " of the Library that is interface-compatible with the Linked" - , " Version. " - , "" - , " e) Provide Installation Information, but only if you would otherwise" - , " be required to provide such information under section 6 of the" - , " GNU GPL, and only to the extent that such information is" - , " necessary to install and execute a modified version of the" - , " Combined Work produced by recombining or relinking the" - , " Application with a modified version of the Linked Version. (If" - , " you use option 4d0, the Installation Information must accompany" - , " the Minimal Corresponding Source and Corresponding Application" - , " Code. If you use option 4d1, you must provide the Installation" - , " Information in the manner specified by section 6 of the GNU GPL" - , " for conveying Corresponding Source.)" - , "" - , " 5. Combined Libraries." - , "" - , " You may place library facilities that are a work based on the" - , "Library side by side in a single library together with other library" - , "facilities that are not Applications and are not covered by this" - , "License, and convey such a combined library under terms of your" - , "choice, if you do both of the following:" - , "" - , " a) Accompany the combined library with a copy of the same work based" - , " on the Library, uncombined with any other library facilities," - , " conveyed under the terms of this License." - , "" - , " b) Give prominent notice with the combined library that part of it" - , " is a work based on the Library, and explaining where to find the" - , " accompanying uncombined form of the same work." - , "" - , " 6. Revised Versions of the GNU Lesser General Public License." - , "" - , " The Free Software Foundation may publish revised and/or new versions" - , "of the GNU Lesser General Public License from time to time. Such new" - , "versions will be similar in spirit to the present version, but may" - , "differ in detail to address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Library as you received it specifies that a certain numbered version" - , "of the GNU Lesser General Public License \"or any later version\"" - , "applies to it, you have the option of following the terms and" - , "conditions either of that published version or of any later version" - , "published by the Free Software Foundation. If the Library as you" - , "received it does not specify a version number of the GNU Lesser" - , "General Public License, you may choose any version of the GNU Lesser" - , "General Public License ever published by the Free Software Foundation." - , "" - , " If the Library as you received it specifies that a proxy can decide" - , "whether future versions of the GNU Lesser General Public License shall" - , "apply, that proxy's public statement of acceptance of any version is" - , "permanent authorization for you to choose that version for the" - , "Library." - ] - diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Types.hs b/cabal-install-0.8.2/Distribution/Client/Init/Types.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Init/Types.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Types --- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Some types used by the 'cabal init' command. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Types where - -import Distribution.Simple.Setup - ( Flag(..) ) - -import Distribution.Version -import qualified Distribution.Package as P -import Distribution.License -import Distribution.ModuleName - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Text - -import Data.Monoid - --- | InitFlags is really just a simple type to represent certain --- portions of a .cabal file. Rather than have a flag for EVERY --- possible field, we just have one for each field that the user is --- likely to want and/or that we are likely to be able to --- intelligently guess. -data InitFlags = - InitFlags { nonInteractive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - - , packageName :: Flag String - , version :: Flag Version - , cabalVersion :: Flag VersionRange - , license :: Flag License - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - - , synopsis :: Flag String - , category :: Flag (Either String Category) - - , packageType :: Flag PackageType - - , exposedModules :: Maybe [ModuleName] - , otherModules :: Maybe [ModuleName] - - , dependencies :: Maybe [P.Dependency] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] - } - deriving (Show) - -data PackageType = Library | Executable - deriving (Show, Read, Eq) - -instance Text PackageType where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] - -instance Monoid InitFlags where - mempty = InitFlags - { nonInteractive = mempty - , quiet = mempty - , packageDir = mempty - , noComments = mempty - , minimal = mempty - , packageName = mempty - , version = mempty - , cabalVersion = mempty - , license = mempty - , author = mempty - , email = mempty - , homepage = mempty - , synopsis = mempty - , category = mempty - , packageType = mempty - , exposedModules = mempty - , otherModules = mempty - , dependencies = mempty - , sourceDirs = mempty - , buildTools = mempty - } - mappend a b = InitFlags - { nonInteractive = combine nonInteractive - , quiet = combine quiet - , packageDir = combine packageDir - , noComments = combine noComments - , minimal = combine minimal - , packageName = combine packageName - , version = combine version - , cabalVersion = combine cabalVersion - , license = combine license - , author = combine author - , email = combine email - , homepage = combine homepage - , synopsis = combine synopsis - , category = combine category - , packageType = combine packageType - , exposedModules = combine exposedModules - , otherModules = combine otherModules - , dependencies = combine dependencies - , sourceDirs = combine sourceDirs - , buildTools = combine buildTools - } - where combine field = field a `mappend` field b - --- | Some common package categories. -data Category - = Codec - | Concurrency - | Control - | Data - | Database - | Development - | Distribution - | Game - | Graphics - | Language - | Math - | Network - | Sound - | System - | Testing - | Text - | Web - deriving (Read, Show, Eq, Ord, Bounded, Enum) - -instance Text Category where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] - -#if MIN_VERSION_base(3,0,0) -#else --- Compat instance for ghc-6.6 era -instance Monoid a => Monoid (Maybe a) where - mempty = Nothing - Nothing `mappend` m = m - m `mappend` Nothing = m - Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) -#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Install.hs b/cabal-install-0.8.2/Distribution/Client/Install.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Install.hs +++ /dev/null @@ -1,786 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, find, nub, sort ) -import Data.Maybe - ( isJust, fromMaybe ) -import qualified Data.Map as Map -import Control.Exception as Exception - ( handleJust ) -#if MIN_VERSION_base(4,0,0) -import Control.Exception as Exception - ( Exception(toException), catches, Handler(Handler), IOException ) -import System.Exit - ( ExitCode ) -#else -import Control.Exception as Exception - ( Exception(IOException, ExitException) ) -#endif -import Distribution.Compat.Exception - ( SomeException, catchIO, catchExit ) -import Control.Monad - ( when, unless ) -import System.Directory - ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) -import System.FilePath - ( (), (<.>), takeDirectory ) -import System.IO - ( openFile, IOMode(AppendMode) ) -import System.IO.Error - ( isDoesNotExistError, ioeGetFileName ) - -import Distribution.Client.Dependency - ( resolveDependenciesWithProgress - , PackageConstraint(..), dependencyConstraints, dependencyTargets - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) - , upgradableDependencies - , Progress(..), foldProgress, ) -import Distribution.Client.Fetch (fetchPackage) -import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) --- import qualified Distribution.Client.Info as Info -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.Setup - ( ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) ) -import Distribution.Client.Config - ( defaultLogsDir, defaultCabalDir ) -import Distribution.Client.Tar (extractTarGzFile) -import Distribution.Client.Types as Available - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), AvailablePackageDb(..) - , Repo(..), ConfiguredPackage(..) - , BuildResult, BuildFailure(..), BuildSuccess(..) - , DocsResult(..), TestsResult(..), RemoteRepo(..) - , InstalledPackage ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -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), compilerFlavor - , PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..), emptyHaddockFlags - , buildCommand, BuildFlags(..), emptyBuildFlags - , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.Setup as Cabal - ( installCommand, InstallFlags(..), emptyInstallFlags ) -import Distribution.Simple.Utils - ( defaultPackageDesc, rawSystemExit, comparing ) -import Distribution.Simple.InstallDirs as InstallDirs - ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate - , initialPathTemplateEnv, installDirsTemplateEnv ) -import Distribution.Package - ( PackageName, PackageIdentifier, packageName, packageVersion - , Package(..), PackageFixedDeps(..) - , Dependency(..), thisPackageVersion ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Version - ( Version, VersionRange, anyVersion, thisVersion ) -import Distribution.Simple.Utils as Utils - ( notice, info, warn, die, intercalate, withTempDirectory ) -import Distribution.Client.Utils - ( inDir, mergeBy, MergeResult(..) ) -import Distribution.System - ( Platform, buildPlatform, OS(Windows), buildOS ) -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 - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> [UnresolvedDependency] - -> IO () -install verbosity packageDB repos comp conf - configFlags configExFlags installFlags deps = - - installWithPlanner planner - verbosity packageDB repos comp conf - configFlags configExFlags installFlags - where - planner :: Planner - planner | null deps = planLocalPackage verbosity - comp configFlags configExFlags - | otherwise = planRepoPackages PreferLatestForSelected - comp configFlags configExFlags installFlags deps - -upgrade verbosity packageDB repos comp conf - configFlags configExFlags installFlags deps = - - installWithPlanner planner - verbosity packageDB repos comp conf - configFlags configExFlags installFlags - where - planner :: Planner - planner | null deps = planUpgradePackages - comp configFlags configExFlags - | otherwise = planRepoPackages PreferAllLatest - comp configFlags configExFlags installFlags deps - -type Planner = Maybe (PackageIndex InstalledPackage) - -> AvailablePackageDb - -> IO (Progress String String InstallPlan) - --- |Installs the packages generated by a planner. -installWithPlanner :: - Planner - -> Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> IO () -installWithPlanner planner verbosity packageDBs repos comp conf - configFlags configExFlags installFlags = do - - installed <- getInstalledPackages verbosity comp packageDBs 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 installed installPlan - - unless dryRun $ do - logsDir <- defaultLogsDir - let platform = InstallPlan.planPlatform installPlan - compid = InstallPlan.planCompiler installPlan - installPlan' <- - executeInstallPlan installPlan $ \cpkg -> - installConfiguredPackage platform compid configFlags - cpkg $ \configFlags' src pkg -> - installAvailablePackage verbosity (packageId pkg) src $ \mpath -> - installUnpackedPackage verbosity (setupScriptOptions installed) - miscOptions configFlags' installFlags - compid pkg mpath (useLogFile logsDir) - - -- build reporting, local and remote - let buildReports = BuildReports.fromInstallPlan installPlan' - BuildReports.storeLocal (installSummaryFile installFlags) buildReports - when (reportingLevel >= AnonymousReports) $ - BuildReports.storeAnonymous buildReports - when (reportingLevel == DetailedReports) $ - storeDetailedBuildReports verbosity logsDir buildReports - regenerateHaddockIndex verbosity packageDBs comp conf - configFlags installFlags installPlan' - symlinkBinaries verbosity configFlags installFlags installPlan' - printBuildFailures installPlan' - - where - setupScriptOptions index = SetupScriptOptions { - useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), - useCompiler = Just comp, - -- Hack: we typically want to allow the UserPackageDB for finding the - -- Cabal lib when compiling any Setup.hs even if we're doing a global - -- install. However we also allow looking in a specific package db. - usePackageDB = if UserPackageDB `elem` packageDBs - then packageDBs - else let (db@GlobalPackageDB:dbs) = packageDBs - in db : UserPackageDB : dbs, - --TODO: use Ord instance: - -- insert UserPackageDB packageDBs - usePackageIndex = if UserPackageDB `elem` packageDBs - then index - else Nothing, - useProgramConfig = conf, - useDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags), - useLoggingHandle = Nothing, - useWorkingDir = Nothing - } - reportingLevel = fromFlag (installBuildReports installFlags) - useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath) - useLogFile logsDir = fmap substLogFileName logFileTemplate - where - logFileTemplate :: Maybe PathTemplate - logFileTemplate --TODO: separate policy from mechanism - | reportingLevel == DetailedReports - = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" - | otherwise - = flagToMaybe (installLogFile installFlags) - substLogFileName template pkg = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) - dryRun = fromFlag (installDryRun installFlags) - miscOptions = InstallMisc { - rootCmd = if fromFlag (configUserInstall configFlags) - then Nothing -- ignore --root-cmd if --user. - else flagToMaybe (installRootCmd installFlags), - libVersion = flagToMaybe (configCabalVersion configExFlags) - } - -storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Repo)] -> IO () -storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- defaultCabalDir - let logFileName = display (BuildReports.package report) <.> "log" - logFile = logsDir logFileName - reportsDir = dotCabal "reports" remoteRepoName remoteRepo - reportFile = reportsDir logFileName - - handleMissingLogFile $ do - buildLog <- readFile logFile - createDirectoryIfMissing True reportsDir -- FIXME - writeFile reportFile (show (BuildReports.show report, buildLog)) - - | (report, Repo { repoKind = Left remoteRepo }) <- reports - , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] - - where - isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True - isLikelyToHaveLogFile BuildReports.BuildFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallOk {} = True - isLikelyToHaveLogFile _ = False - - handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> - warn verbosity $ "Missing log file for build report: " - ++ fromMaybe "" (ioeGetFileName ioe) - -#if MIN_VERSION_base(4,0,0) - missingFile ioe -#else - missingFile (IOException ioe) -#endif - | isDoesNotExistError ioe = Just ioe - missingFile _ = Nothing - -regenerateHaddockIndex :: Verbosity - -> [PackageDB] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> IO () -regenerateHaddockIndex verbosity packageDBs comp conf - configFlags installFlags installPlan - | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do - - defaultDirs <- InstallDirs.defaultInstallDirs - (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) - True - let indexFileTemplate = fromFlag (installHaddockIndex installFlags) - indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate - - notice verbosity $ - "Updating documentation index " ++ indexFile - - --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installed <- getInstalledPackages verbosity comp packageDBs conf - case installed of - Nothing -> return () -- warning ? - Just index -> Haddock.regenerateHaddockIndex verbosity index conf indexFile - - | otherwise = return () - where - haddockIndexFileIsRequested = - fromFlag (installDocumentation installFlags) - && isJust (flagToMaybe (installHaddockIndex installFlags)) - - -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index is per-user, we don't do it for global - -- installs or special cases where we're installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall - && someDocsWereInstalled installPlan - where - someDocsWereInstalled = any installedDocs . InstallPlan.toList - normalUserInstall = (UserPackageDB `elem` packageDBs) - && all (not . isSpecificPackageDB) packageDBs - - installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True - installedDocs _ = False - isSpecificPackageDB (SpecificPackageDB _) = True - isSpecificPackageDB _ = False - - substHaddockIndexFileName defaultDirs = fromPathTemplate - . substPathTemplate env - where - env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerId comp) - ++ InstallDirs.platformTemplateEnv (buildPlatform) - absoluteDirs = InstallDirs.substituteInstallDirTemplates - env0 templateDirs - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> ConfigFlags -> ConfigExFlags -> Planner -planLocalPackage verbosity comp configFlags configExFlags installed - (AvailablePackageDb available availablePrefs) = 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 - } - targets = [packageName pkg] - constraints = [PackageVersionConstraint (packageName pkg) - (thisVersion (packageVersion pkg)) - ,PackageFlagsConstraint (packageName pkg) - (configConfigurationsFlags configFlags)] - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs PreferLatestForSelected - availablePrefs configExFlags - - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available' preferences constraints targets - --- | Make an 'InstallPlan' for the given dependencies. --- -planRepoPackages :: PackagesPreferenceDefault -> Compiler - -> ConfigFlags -> ConfigExFlags -> InstallFlags - -> [UnresolvedDependency] -> Planner -planRepoPackages defaultPref comp configFlags configExFlags installFlags - deps installed (AvailablePackageDb available availablePrefs) = do - - deps' <- IndexUtils.disambiguateDependencies available deps - let installed' - | fromFlag (installReinstall installFlags) - = fmap (hideGivenDeps deps') installed - | otherwise = installed - targets = dependencyTargets deps' - constraints = dependencyConstraints deps' - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs defaultPref availablePrefs configExFlags - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available preferences constraints targets - where - hideGivenDeps pkgs index = - foldr PackageIndex.deletePackageName index - [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] - -planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner -planUpgradePackages _comp _configFlags _configExFlags (Just installed) - (AvailablePackageDb available _availablePrefs) = die $ - "the 'upgrade' command (when used without any package arguments) has " - ++ "been disabled in this release. It has been disabled because it has " - ++ "frequently led people to accidentally break their set of installed " - ++ "packages. It will be re-enabled when it is safer to use.\n" - ++ "Below is the list of packages that it would have tried to upgrade. You " - ++ "can use the 'install' command to install the ones you want. Note that " - ++ "it is generally not recommended to upgrade core packages.\n" - ++ unlines [ display pkgid | Dependency pkgid _ <- deps ] - ---TODO: improve upgrade so we can re-enable it --- return $ --- resolveDependenciesWithProgress buildPlatform (compilerId comp) --- (Just installed) available preferences constraints targets - where - deps = upgradableDependencies installed available --- preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags --- constraints = [ PackageVersionConstraint name ver --- | Dependency name ver <- deps ] --- ++ [ PackageVersionConstraint name ver --- | Dependency name ver <- configConstraints configFlags ] --- targets = [ name | Dependency name _ <- deps ] - -planUpgradePackages comp _ _ _ _ = - die $ display (compilerId comp) - ++ " does not track installed packages so cabal cannot figure out what" - ++ " packages need to be upgraded." - -mergePackagePrefs :: PackagesPreferenceDefault - -> Map.Map PackageName VersionRange - -> ConfigExFlags - -> PackagesPreference -mergePackagePrefs defaultPref availablePrefs configExFlags = - PackagesPreference defaultPref $ - -- The preferences that come from the hackage index - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] - -- additional preferences from the config file or command line - ++ [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] - -printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage) - -> InstallPlan -> IO () -printDryRun verbosity minstalled plan = case unfoldr next plan of - [] -> return () - pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - "In order, the following would be installed:" - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - "In order, the following would be installed (use -v for more details):" - : map (display . packageId) pkgs - where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just (pkg, 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 - - showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ - case minstalled of - Nothing -> "" - Just installed -> - case PackageIndex.lookupPackageName installed (packageName pkg') of - [] -> "(new package)" - ps -> case find ((==packageId pkg') . packageId) ps of - Nothing -> "(new version)" - Just pkg -> "(reinstall)" ++ case changes pkg pkg' of - [] -> "" - diff -> " changes: " ++ intercalate ", " diff - changes pkg pkg' = map change . filter changed - $ mergeBy (comparing packageName) - (nub . sort . depends $ pkg) - (nub . sort . depends $ pkg') - change (OnlyInLeft pkgid) = display pkgid ++ " removed" - change (InBoth pkgid pkgid') = display pkgid ++ " -> " - ++ display (packageVersion pkgid') - change (OnlyInRight pkgid') = display pkgid' ++ " added" - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True - -symlinkBinaries :: Verbosity - -> 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 = 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." - DownloadFailed e -> " failed while downloading the package." - ++ " The exception was:\n " ++ show e - 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 :: Platform -> CompilerId - -> ConfigFlags -> ConfiguredPackage - -> (ConfigFlags -> AvailablePackageSource - -> PackageDescription -> a) - -> a -installConfiguredPackage platform comp configFlags - (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) - installPkg = installPkg configFlags { - configConfigurationsFlags = flags, - configConstraints = map thisPackageVersion deps - } source pkg - where - pkg = case finalizePackageDescription flags - (const True) - platform 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 = - onFailure DownloadFailed $ do - pkgPath <- fetchPackage verbosity repo pkgid - onFailure UnpackFailed $ do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do - info verbosity $ "Extracting " ++ pkgPath - ++ " to " ++ tmpDirPath ++ "..." - let relUnpackedPath = display pkgid - absUnpackedPath = tmpDirPath relUnpackedPath - descFilePath = absUnpackedPath - display (packageName pkgid) <.> "cabal" - extractTarGzFile tmpDirPath relUnpackedPath pkgPath - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath - installPkg (Just absUnpackedPath) - -installUnpackedPackage :: Verbosity - -> SetupScriptOptions - -> InstallMisc - -> 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 (do setup haddockCommand haddockFlags - return DocsOk) - `catchIO` (\_ -> return DocsFailed) - `catchExit` (\_ -> return DocsFailed) - 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 { - configVerbosity = toFlag verbosity' - } - buildCommand' = buildCommand defaultProgramConfiguration - buildFlags _ = emptyBuildFlags { - buildDistPref = configDistPref configFlags, - buildVerbosity = toFlag verbosity' - } - shouldHaddock = fromFlag (installDocumentation installConfigFlags) - haddockFlags _ = emptyHaddockFlags { - haddockDistPref = configDistPref configFlags, - haddockVerbosity = toFlag verbosity' - } - installFlags _ = Cabal.emptyInstallFlags { - Cabal.installDistPref = configDistPref configFlags, - Cabal.installVerbosity = toFlag verbosity' - } - verbosity' | isJust useLogFile = max Verbosity.verbose verbosity - | otherwise = verbosity - setup cmd flags = do - logFileHandle <- case useLogFile of - Nothing -> return Nothing - Just mkLogFileName -> do - let logFileName = mkLogFileName (packageId pkg) - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFile <- openFile logFileName AppendMode - return (Just logFile) - - 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 :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult -onFailure result action = -#if MIN_VERSION_base(4,0,0) - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] - where - handler :: Exception e => e -> IO BuildResult - handler = return . Left . result . toException -#else - action - `catchIO` (return . Left . result . IOException) - `catchExit` (return . Left . result . ExitException) -#endif - -withWin32SelfUpgrade :: Verbosity - -> ConfigFlags - -> CompilerId - -> PackageDescription - -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity configFlags compid pkg action = do - - defaultDirs <- InstallDirs.defaultInstallDirs - compFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - - Win32SelfUpgrade.possibleSelfUpgrade verbosity - (exeInstallPaths defaultDirs) action - - where - pkgid = packageId pkg - (CompilerId compFlavor _) = 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 = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (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/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs b/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs +++ /dev/null @@ -1,495 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - planPlatform, - 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(..) - , InstalledPackage - , BuildFailure, BuildSuccess ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..), packageName - , PackageFixedDeps(..), Dependency(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.PackageDescription - ( GenericPackageDescription(genPackageFlags) - , Flag(flagName), FlagName(..) ) -import Distribution.Client.PackageUtils - ( externalBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Text - ( display ) -import Distribution.System - ( Platform ) -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 InstalledPackage - | 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, - planPkgOf :: Graph.Vertex -> PlanPackage, - planVertexOf :: PackageIdentifier -> Graph.Vertex, - planPlatform :: Platform, - planCompiler :: CompilerId - } - -invariant :: InstallPlan -> Bool -invariant plan = - valid (planPlatform 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 :: Platform -> CompilerId -> PackageIndex PlanPackage - -> Either [PlanProblem] InstallPlan -new platform compiler index = - case problems platform compiler index of - [] -> Right InstallPlan { - planIndex = index, - planGraph = graph, - planGraphRev = Graph.transposeG graph, - planPkgOf = vertexToPkgId, - planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, - planPlatform = platform, - 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 checkConfiguredPackage - $ packagesThatDependOn plan pkgid ] - --- | lookup the reachable packages in the reverse dependency graph --- -packagesThatDependOn :: InstallPlan - -> PackageIdentifier -> [PlanPackage] -packagesThatDependOn plan = map (planPkgOf 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 - --- | check a package that we expect to be in the configured or failed state --- -checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage -checkConfiguredPackage (Configured pkg) = Just pkg -checkConfiguredPackage (Failed _ _) = Nothing -checkConfiguredPackage pkg = - internalError $ "not configured or no such pkg " ++ display (packageId pkg) - --- ------------------------------------------------------------ --- * 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 :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool -valid platform comp index = null (problems platform comp index) - -data PlanProblem = - PackageInvalid ConfiguredPackage [PackageProblem] - | PackageMissingDeps PlanPackage [PackageIdentifier] - | PackageCycle [PlanPackage] - | PackageInconsistency PackageName [(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 " ++ display 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 :: Platform -> CompilerId - -> PackageIndex PlanPackage -> [PlanProblem] -problems platform comp index = - [ PackageInvalid pkg packageProblems - | Configured pkg <- PackageIndex.allPackages index - , let packageProblems = configuredPackageProblems platform 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 :: Platform -> CompilerId -> ConfiguredPackage -> Bool -configuredPackageValid platform comp pkg = - null (configuredPackageProblems platform 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 :: Platform -> CompilerId - -> ConfiguredPackage -> [PackageProblem] -configuredPackageProblems platform 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 - (const True) - platform comp - [] - (packageDescription pkg) of - Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg - Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs b/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# 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 System.Posix.Files - ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink - , removeLink ) -import System.Directory - ( canonicalizePath ) -import System.FilePath - ( (), splitPath, joinPath, isAbsolute ) - -import Prelude hiding (catch, ioError) -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 - (const True) - platform 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) - platform = InstallPlan.planPlatform 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 privateName) - 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 target (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 binary. - -- Use 'canonicalizePath' to make this. - -> IO SymlinkStatus -targetOkToOverwrite symlink target = handleNotExist $ do - status <- getSymbolicLinkStatus symlink - if not (isSymbolicLink status) - then return NotOurFile - else do target' <- canonicalizePath symlink - -- This relies on canonicalizePath handling symlinks - if target == target' - then return OkToOverwrite - else return NotOurFile - - 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/cabal-install-0.8.2/Distribution/Client/List.hs b/cabal-install-0.8.2/Distribution/Client/List.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/List.hs +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.List --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2008-2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- --- Search for and print information about packages ------------------------------------------------------------------------------ -module Distribution.Client.List ( - list, info - ) where - -import Distribution.Package - ( PackageName(..), packageName, packageVersion - , Dependency(..), thisPackageVersion, depends ) -import Distribution.ModuleName (ModuleName) -import Distribution.License (License) -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.PackageDescription as Available -import Distribution.PackageDescription - ( Flag(..), FlagName(..) ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) - -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.Simple.Utils (equating, comparing, notice) -import Distribution.Simple.Setup (fromFlag) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Version (Version) -import Distribution.Verbosity (Verbosity) -import Distribution.Text - ( Text(disp), display ) - -import Distribution.Client.Types - ( AvailablePackage(..), Repo, AvailablePackageDb(..) - , UnresolvedDependency(..), InstalledPackage(..) ) -import Distribution.Client.Setup - ( ListFlags(..), InfoFlags(..) ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import Distribution.Client.Fetch - ( isFetched ) - -import Data.List - ( sortBy, groupBy, sort, nub, intersperse, maximumBy ) -import Data.Maybe - ( listToMaybe, fromJust, fromMaybe, isJust, isNothing ) -import Control.Monad - ( MonadPlus(mplus), join ) -import Control.Exception - ( assert ) -import Text.PrettyPrint.HughesPJ as Disp -import System.Directory - ( doesDirectoryExist ) - - --- |Show information about packages -list :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ListFlags - -> [String] - -> IO () -list verbosity packageDBs repos comp conf listFlags pats = do - Just installed <- getInstalledPackages verbosity comp packageDBs conf - AvailablePackageDb 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 - [ display (pkgname 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 showPackageSummaryInfo matches) - where - installedFilter - | onlyInstalled = filter (not . null . installedVersions) - | otherwise = id - onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - -info :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> InfoFlags - -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint - -> IO () -info verbosity packageDBs repos comp conf _listFlags deps = do - AvailablePackageDb available _ <- getAvailablePackages verbosity repos - deps' <- IndexUtils.disambiguateDependencies available deps - Just installed <- getInstalledPackages verbosity comp packageDBs conf - let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ] - let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps'' - ,concatMap (PackageIndex.lookupPackageName available) deps'') - pkgsinfo = map (uncurry mergePackageInfo) - $ uncurry mergePackages pkgs - - pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo - putStr $ unlines (map showPackageDetailedInfo pkgsinfo') - --- | 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 { - pkgname :: PackageName, - allInstalled :: [InstalledPackage], - allAvailable :: [AvailablePackage], - latestInstalled :: Maybe InstalledPackage, - latestAvailable :: Maybe AvailablePackage, - homepage :: String, - bugReports :: String, - sourceRepo :: String, - synopsis :: String, - description :: String, - category :: String, - license :: License, --- copyright :: String, --TODO: is this useful? - author :: String, - maintainer :: String, - dependencies :: [Dependency], - flags :: [Flag], - hasLib :: Bool, - hasExe :: Bool, - executables :: [String], - modules :: [ModuleName], - haddockHtml :: FilePath, - haveTarball :: Bool - } - -installedVersions :: PackageDisplayInfo -> [Version] -installedVersions = map packageVersion . allInstalled - -availableVersions :: PackageDisplayInfo -> [Version] -availableVersions = map packageVersion . allAvailable - -showPackageSummaryInfo :: PackageDisplayInfo -> String -showPackageSummaryInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> disp (pkgname pkginfo) - $+$ - (nest 4 $ vcat [ - maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs - , text "Latest version available:" <+> - case latestAvailable pkginfo of - Nothing -> text "[ Not available from server ]" - Just pkg -> disp (packageVersion pkg) - , text "Latest version installed:" <+> - case latestInstalled pkginfo of - Nothing | hasLib pkginfo -> text "[ Not installed ]" - | otherwise -> text "[ Unknown ]" - Just pkg -> disp (packageVersion pkg) - , maybeShow (homepage pkginfo) "Homepage:" text - , text "License: " <+> text (display (license pkginfo)) - ]) - $+$ text "" - where - maybeShow [] _ _ = empty - maybeShow l s f = text s <+> (f l) - -showPackageDetailedInfo :: PackageDisplayInfo -> String -showPackageDetailedInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> disp (pkgname pkginfo) - <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ') - <> parens pkgkind - $+$ - (nest 4 $ vcat [ - entry "Synopsis" synopsis alwaysShow reflowParagraphs - , entry "Latest version available" latestAvailable - (altText isNothing "[ Not available from server ]") - (disp . packageVersion . fromJust) - , entry "Latest version installed" latestInstalled - (altText isNothing (if hasLib pkginfo then "[ Not installed ]" - else "[ Unknown ]")) - (disp . packageVersion . fromJust) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description alwaysShow reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep disp) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) then empty else - text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ]) - $+$ text "" - where - entry fname field cond format = case cond (field pkginfo) of - Nothing -> label <+> format (field pkginfo) - Just Nothing -> empty - Just (Just other) -> label <+> text other - where - label = text fname <> char ':' <> padding - padding = text (replicate (13 - length fname ) ' ') - - normal = Nothing - hide = Just Nothing - replace msg = Just (Just msg) - - alwaysShow = const normal - hideIfNull v = if null v then hide else normal - showIfInstalled v - | not isInstalled = hide - | null v = replace "[ Not installed ]" - | otherwise = normal - altText nul msg v = if nul v then replace msg else normal - orNotSpecified = altText null "[ Not specified ]" - - commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f - dispFlag f = case flagName f of FlagName n -> text n - dispYesNo True = text "Yes" - dispYesNo False = text "No" - - isInstalled = not (null (installedVersions pkginfo)) - hasExes = length (executables pkginfo) >= 2 - --TODO: exclude non-buildable exes - pkgkind | hasLib pkginfo && hasExes = text "programs and library" - | hasLib pkginfo && hasExe pkginfo = text "program and library" - | hasLib pkginfo = text "library" - | hasExes = text "programs" - | hasExe pkginfo = text "program" - | otherwise = empty - -reflowParagraphs :: String -> Doc -reflowParagraphs = - vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paragraphs - . filter (/= [""]) - . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines - -reflowLines :: String -> Doc -reflowLines = vcat . map text . 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 :: [InstalledPackage] - -> [AvailablePackage] - -> PackageDisplayInfo -mergePackageInfo installedPkgs availablePkgs = - assert (length installedPkgs + length availablePkgs > 0) $ - PackageDisplayInfo { - pkgname = combine packageName available - packageName installed, - allInstalled = installedPkgs, - allAvailable = availablePkgs, - latestInstalled = latest installedPkgs, - latestAvailable = latest availablePkgs, - license = combine Available.license available - Installed.license installed, - maintainer = combine Available.maintainer available - Installed.maintainer installed, - author = combine Available.author available - Installed.author installed, - homepage = combine Available.homepage available - Installed.homepage installed, - bugReports = maybe "" Available.bugReports available, - sourceRepo = fromMaybe "" . join - . fmap (uncons Nothing Available.repoLocation - . sortBy (comparing Available.repoKind) - . Available.sourceRepos) - $ available, - synopsis = combine Available.synopsis available - Installed.description installed, - description = combine Available.description available - Installed.description installed, - category = combine Available.category available - Installed.category installed, - flags = maybe [] Available.genPackageFlags availableGeneric, - hasLib = isJust installed - || fromMaybe False - (fmap (isJust . Available.condLibrary) availableGeneric), - hasExe = fromMaybe False - (fmap (not . null . Available.condExecutables) availableGeneric), - executables = map fst (maybe [] Available.condExecutables availableGeneric), - modules = combine Installed.exposedModules installed - (maybe [] Available.exposedModules - . Available.library) available, - dependencies = combine Available.buildDepends available - (map thisPackageVersion . depends) installed', - haddockHtml = fromMaybe "" . join - . fmap (listToMaybe . Installed.haddockHTMLs) - $ installed, - haveTarball = False - } - where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed' = latest installedPkgs - installed = fmap (\(InstalledPackage p _) -> p) installed' - availableGeneric = fmap packageDescription (latest availablePkgs) - available = fmap flattenPackageDescription availableGeneric - latest [] = Nothing - latest pkgs = Just (maximumBy (comparing packageVersion) pkgs) - - uncons :: b -> (a -> b) -> [a] -> b - uncons z _ [] = z - uncons _ f (x:_) = f x - --- | Not all the info is pure. We have to check if the docs really are --- installed, because the registered package info lies. Similarly we have to --- check if the tarball has indeed been fetched. --- -updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo -updateFileSystemPackageDetails pkginfo = do - fetched <- maybe (return False) isFetched (latestAvailable pkginfo) - docsExist <- doesDirectoryExist (haddockHtml pkginfo) - return pkginfo { - haveTarball = fetched, - haddockHtml = if docsExist then haddockHtml pkginfo else "" - } - --- | 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 :: [InstalledPackage] -> [AvailablePackage] - -> [([InstalledPackage], [AvailablePackage])] -mergePackages installed available = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn packageName installed) - (groupOn packageName 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/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs b/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs +++ /dev/null @@ -1,479 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Client.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - ) where - -import Prelude hiding (lookup) -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Tree as Tree -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Data.Array ((!)) -import Data.List (groupBy, sortBy, nub, find, isInfixOf) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromMaybe) - -import Distribution.Package - ( PackageName(..), PackageIdentifier(..) - , Package(..), packageName, packageVersion - , Dependency(Dependency), PackageFixedDeps(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, equating, comparing) - - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched effeciently by package name and version. --- -newtype Package pkg => PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - - deriving (Show, Read) - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex (Map.empty) - mappend = merge - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = foldr1 mappend xs - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - --- --- * Internal helpers --- - -mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-sensitively. --- -lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg -deleteDependency (Dependency name verstionRange) = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: Package pkg => PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = Map.elems m - --- --- * Lookups --- - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] -lookupDependency index (Dependency name versionRange) = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insentiviely to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insentiviely but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insentiviely and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] -searchByName (PackageIndex m) name = - case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m - , lowercase name' == lname ] of - [] -> None - [(_,pkgs)] -> Unambiguous pkgs - pkgss -> case find ((PackageName name==) . fst) pkgss of - Just (_,pkgs) -> Unambiguous pkgs - Nothing -> Ambiguous (map snd pkgss) - where lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] -searchByNameSubstring (PackageIndex m) searchterm = - [ pkg - | (PackageName name, pkgs) <- Map.toList m - , lsearchterm `isInfixOf` lowercase name - , pkg <- pkgs ] - where lsearchterm = lowercase searchterm - --- --- * Special queries --- - --- | All packages that have dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(pkg, [PackageIdentifier])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- depends pkg - , isNothing (lookupPackageId index pkg') ] - , not (null missing) ] - --- | Tries to take the transative closure of the package dependencies. --- --- If the transative closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageIdentifier's do not occur in the index. --- -dependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> Either (PackageIndex pkg) - [(pkg, [PackageIdentifier])] -dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupPackageId completed (packageId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = depends pkg ++ pkgids - --- | Takes the transative closure of the packages reverse dependencies. --- --- * The given 'PackageIdentifier's must be in the index. --- -reverseDependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> [pkg] -reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - - where - (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index - reverseDepGraph = Graph.transposeG depGraph - noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" - -topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index - -reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies index = - [ (name, inconsistencies) - | (name, uses) <- Map.toList inverseIndex - , let inconsistencies = duplicatesBy uses - versions = map snd inconsistencies - , reallyIsInconsistent name (nub versions) ] - - where inverseIndex = Map.fromListWith (++) - [ (packageName dep, [(packageId pkg, packageVersion dep)]) - | pkg <- allPackages index - , dep <- depends pkg ] - - duplicatesBy = (\groups -> if length groups == 1 - then [] - else concat groups) - . groupBy (equating snd) - . sortBy (comparing snd) - - reallyIsInconsistent :: PackageName -> [Version] -> Bool - reallyIsInconsistent _ [] = False - reallyIsInconsistent name [v1, v2] = - case (mpkg1, mpkg2) of - (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 - && pkgid2 `notElem` depends pkg1 - _ -> True - where - pkgid1 = PackageIdentifier name v1 - pkgid2 = PackageIdentifier name v2 - mpkg1 = lookupPackageId index pkgid1 - mpkg2 = lookupPackageId index pkgid2 - - reallyIsInconsistent _ _ = True - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: PackageFixedDeps pkg - => PackageIndex pkg - -> [[pkg]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, packageId pkg, depends pkg) - | pkg <- allPackages index ] - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageFixedDeps pkg - => PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> pkg, - PackageIdentifier -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) - where - graph = Array.listArray bounds - [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] - | pkg <- pkgs ] - vertexToPkg vertex = pkgTable ! vertex - pkgIdToVertex = binarySearch 0 topBound - - pkgTable = Array.listArray bounds pkgs - pkgIdTable = Array.listArray bounds (map packageId pkgs) - pkgs = sortBy (comparing packageId) (allPackages index) - topBound = length pkgs - 1 - bounds = (0, topBound) - - binarySearch a b key - | a > b = Nothing - | otherwise = case compare key (pkgIdTable ! mid) of - LT -> binarySearch a (mid-1) key - EQ -> Just mid - GT -> binarySearch (mid+1) b key - where mid = (a + b) `div` 2 diff --git a/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs b/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PackageUtils --- Copyright : (c) Duncan Coutts 2010 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Various package description utils that should be in the Cabal lib ------------------------------------------------------------------------------ -module Distribution.Client.PackageUtils ( - externalBuildDepends, - ) where - -import Distribution.Package - ( packageVersion, packageName, Dependency(..) ) -import Distribution.PackageDescription - ( PackageDescription(..) ) -import Distribution.Version - ( withinRange ) - --- | The list of dependencies that refer to external packages --- rather than internal package components. --- -externalBuildDepends :: PackageDescription -> [Dependency] -externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) - where - -- True if this dependency is an internal one (depends on a library - -- defined in the same package). - internal (Dependency depName versionRange) = - depName == packageName pkg && - packageVersion pkg `withinRange` versionRange diff --git a/cabal-install-0.8.2/Distribution/Client/Setup.hs b/cabal-install-0.8.2/Distribution/Client/Setup.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Setup.hs +++ /dev/null @@ -1,876 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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, ConfigFlags(..), filterConfigureFlags - , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , configureExOptions - , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , listCommand, ListFlags(..) - , updateCommand - , upgradeCommand - , infoCommand, InfoFlags(..) - , fetchCommand - , checkCommand - , uploadCommand, UploadFlags(..) - , reportCommand - , unpackCommand, UnpackFlags(..) - , initCommand, IT.InitFlags(..) - - , parsePackageArgs - --TODO: stop exporting these: - , showRepo - , parseRepo - ) where - -import Distribution.Client.Types - ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..), PackageType(..) ) - -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 - ( configureCommand ) -import Distribution.Simple.Setup - ( ConfigFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe - , optionVerbosity, trueArg ) -import Distribution.Simple.InstallDirs - ( PathTemplate, toPathTemplate, fromPathTemplate ) -import Distribution.Version - ( Version(Version), anyVersion, thisVersion ) -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 Distribution.Simple.Utils - ( wrapText ) - -import Data.Char - ( isSpace, isAlphaNum ) -import Data.Maybe - ( listToMaybe, maybeToList, fromMaybe ) -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 = "", - commandUsage = \_ -> - "This program is the command line interface " - ++ "to the Haskell Cabal infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n", - commandDescription = Just $ \pname -> - "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n\n" - ++ "Occasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n", - 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 ConfigFlags -configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { - commandDefaultFlags = mempty - } - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions = commandOptions configureCommand - -filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags -filterConfigureFlags flags cabalLibVersion - | cabalLibVersion >= Version [1,3,10] [] = flags - -- older Cabal does not grok the constraints flag: - | otherwise = flags { configConstraints = [] } - - --- ------------------------------------------------------------ --- * Config extra flags --- ------------------------------------------------------------ - --- | cabal configure takes some extra flags beyond runghc Setup configure --- -data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configPreferences :: [Dependency] - } - -defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty - -configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) -configureExCommand = configureCommand { - commandDefaultFlags = (mempty, defaultConfigExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst (configureOptions showOrParseArgs) - ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) - } - where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) - -configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs = - [ option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) - (fmap toFlag parse)) - (map display . flagToList)) - - , option [] ["preference"] - "Specify preferences (soft constraints) on the version of a package" - configPreferences (\v flags -> flags { configPreferences = v }) - (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) - ] - -instance Monoid ConfigExFlags where - mempty = ConfigExFlags { - configCabalVersion = mempty, - configPreferences = mempty - } - mappend a b = ConfigExFlags { - configCabalVersion = combine configCabalVersion, - configPreferences = combine configPreferences - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Other commands --- ------------------------------------------------------------ - -fetchCommand :: CommandUI (Flag Verbosity) -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation.", - 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 (ConfigFlags, ConfigExFlags, InstallFlags) -upgradeCommand = configureCommand { - commandName = "upgrade", - commandSynopsis = "Upgrades installed packages to the latest available version", - commandDescription = Nothing, - commandUsage = usagePackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty), - commandOptions = commandOptions installCommand - } - -{- -cleanCommand :: CommandUI () -cleanCommand = makeCommand name shortDesc longDesc emptyFlags options - where - name = "clean" - shortDesc = "Removes downloaded files" - longDesc = Nothing - emptyFlags = () - options _ = [] --} - -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 = \_ -> [] - } - -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] - } - --- ------------------------------------------------------------ --- * Unpack flags --- ------------------------------------------------------------ - -data UnpackFlags = UnpackFlags { - unpackDestDir :: Flag FilePath, - unpackVerbosity :: Flag Verbosity - } - -defaultUnpackFlags :: UnpackFlags -defaultUnpackFlags = UnpackFlags { - unpackDestDir = mempty, - unpackVerbosity = toFlag normal - } - -unpackCommand :: CommandUI UnpackFlags -unpackCommand = CommandUI { - commandName = "unpack", - commandSynopsis = "Unpacks packages for user inspection.", - commandDescription = Nothing, - commandUsage = usagePackages "unpack", - commandDefaultFlags = mempty, - commandOptions = \_ -> [ - optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) - - ,option "d" ["destdir"] - "where to unpack the packages, defaults to the current directory." - unpackDestDir (\v flags -> flags { unpackDestDir = v }) - (reqArgFlag "PATH") - ] - } - -instance Monoid UnpackFlags where - mempty = defaultUnpackFlags - mappend a b = UnpackFlags { - unpackDestDir = combine unpackDestDir - ,unpackVerbosity = combine unpackVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * 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 packages matching a search string.", - 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 - --- ------------------------------------------------------------ --- * Info flags --- ------------------------------------------------------------ - -data InfoFlags = InfoFlags { - infoVerbosity :: Flag Verbosity - } - -defaultInfoFlags :: InfoFlags -defaultInfoFlags = InfoFlags { - infoVerbosity = toFlag normal - } - -infoCommand :: CommandUI InfoFlags -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Nothing, - commandUsage = usagePackages "info", - commandDefaultFlags = defaultInfoFlags, - commandOptions = \_ -> [ - optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) - ] - } - -instance Monoid InfoFlags where - mempty = defaultInfoFlags - mappend a b = InfoFlags { - infoVerbosity = combine infoVerbosity - } - 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, - installHaddockIndex :: Flag PathTemplate, - installDryRun :: Flag Bool, - installReinstall :: Flag Bool, - installOnly :: Flag Bool, - installRootCmd :: Flag String, - installSummaryFile :: [PathTemplate], - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installSymlinkBinDir:: Flag FilePath - } - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDocumentation= Flag False, - installHaddockIndex = Flag docIndexFile, - installDryRun = Flag False, - installReinstall = Flag False, - installOnly = Flag False, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installSymlinkBinDir= mempty - } - where - docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") - -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) -installCommand = CommandUI { - commandName = "install", - commandSynopsis = "Installs a list of packages.", - commandUsage = usagePackages "install", - commandDescription = Just $ \pname -> - let original = case commandDescription configureCommand of - Just desc -> desc pname ++ "\n" - Nothing -> "" - in original - ++ "Examples:\n" - ++ " " ++ pname ++ " install " - ++ " Package in the current directory\n" - ++ " " ++ pname ++ " install foo " - ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " install foo-1.0 " - ++ " Specific version of a package\n" - ++ " " ++ pname ++ " install 'foo < 2' " - ++ " Constrained package version\n", - commandDefaultFlags = (mempty, mempty, mempty), - commandOptions = \showOrParseArgs -> - liftOptions get1 set1 (configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) - ++ liftOptions get3 set3 (installOptions showOrParseArgs) - } - where - get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) - get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) - get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [ option "" ["documentation"] - "building of documentation" - installDocumentation (\v flags -> flags { installDocumentation = v }) - (boolOpt [] []) - - , option [] ["doc-index-file"] - "A central index of haddock API documentation (template cannot use $pkgid)" - installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , 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 [] ["build-summary"] - "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" - installSummaryFile (\v flags -> flags { installSummaryFile = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) - - , option [] ["build-log"] - "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" - installLogFile (\v flags -> flags { installLogFile = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["remote-build-reporting"] - "Generate build reports to send to a remote server (none, anonymous or detailed)." - installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " - ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - ] ++ 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, - installHaddockIndex = mempty, - installDryRun = mempty, - installReinstall = mempty, - installOnly = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = mempty, - installSymlinkBinDir= mempty - } - mappend a b = InstallFlags { - installDocumentation= combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installReinstall = combine installReinstall, - installOnly = combine installOnly, - installRootCmd = combine installRootCmd, - installSummaryFile = combine installSummaryFile, - 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 - --- ------------------------------------------------------------ --- * Init flags --- ------------------------------------------------------------ - -emptyInitFlags :: IT.InitFlags -emptyInitFlags = mempty - -defaultInitFlags :: IT.InitFlags -defaultInitFlags = emptyInitFlags - -initCommand :: CommandUI IT.InitFlags -initCommand = CommandUI { - commandName = "init", - commandSynopsis = "Interactively create a .cabal file.", - commandDescription = Just $ \_ -> wrapText $ - "Cabalise a project by creating a .cabal, Setup.hs, and " - ++ "optionally a LICENSE file.\n\n" - ++ "Calling init with no arguments (recommended) uses an " - ++ "interactive mode, which will try to guess as much as " - ++ "possible and prompt you for the rest. Command-line " - ++ "arguments are provided for scripting purposes. " - ++ "If you don't want interactive mode, be sure to pass " - ++ "the -n flag.\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " init [FLAGS]\n\n" - ++ "Flags for init:", - commandDefaultFlags = defaultInitFlags, - commandOptions = \_ -> - [ option ['n'] ["non-interactive"] - "Non-interactive mode." - IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) - trueArg - - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg - - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg - - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg - - , option [] ["package-dir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") - - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArgFlag "PACKAGE") - - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option [] ["cabal-version"] - "Required version of the Cabal library." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") - - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") - - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") - - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") - - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) - - , option [] ["is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) - - , option [] ["is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) - - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) - - , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) - - , option [] ["source-dir"] - "Directory containing package source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) - ] - } - where readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing - --- ------------------------------------------------------------ --- * 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 - -liftOptions :: (b -> a) -> (a -> b -> b) - -> [OptionField a] -> [OptionField b] -liftOptions get set = map (liftOption get set) - -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 $ - show arg ++ " is not valid syntax for a package name or" - ++ " package dependency." - -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - -parseDependencyOrPackageId :: Parse.ReadP r Dependency -parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse - where - 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/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs b/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs +++ /dev/null @@ -1,321 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Distribution.Client.Types - ( InstalledPackage ) - -import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version(..), VersionRange, anyVersion, intersectVersionRanges - , withinRange ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..), packageName - , packageVersion, Dependency(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), BuildType(..) ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.Simple.Configure - ( configCompiler ) -import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) -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.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Client.IndexUtils - ( getInstalledPackages ) -import Distribution.Simple.Utils - ( die, debug, info, cabalVersion, findPackageDesc, comparing - , createDirectoryIfMissingVerbose, rewriteFile ) -import Distribution.Client.Utils - ( moreRecentFile, inDir ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory ( doesFileExist, getCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( Handle ) -import System.Exit ( ExitCode(..), exitWith ) -import System.Process ( runProcess, waitForProcess ) -import Control.Monad ( when, unless ) -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, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe (PackageIndex InstalledPackage), - useProgramConfig :: ProgramConfiguration, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath - } - -defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCompiler = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - 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 = case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir - 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 == PackageName "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 (usePackageDB options') conf - - let cabalDep = Dependency (PackageName "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' - --TODO: get Cabal's GHC module to export a GhcOptions type and render func - rawSystemProgramConf verbosity ghcProgram conf $ - ghcVerbosityOptions verbosity - ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir - ,"-i", "-i" ++ workingDir ] - ++ ghcPackageDbOptions (usePackageDB options') - ++ if packageName pkg == PackageName "Cabal" - then [] - else ["-package", display cabalPkgid] - where - cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - - ghcPackageDbOptions :: PackageDBStack -> [String] - ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error "internal error: unexpected package db stack" - - - 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 diff --git a/cabal-install-0.8.2/Distribution/Client/SrcDist.hs b/cabal-install-0.8.2/Distribution/Client/SrcDist.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/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 Distribution.Client.SrcDist ( - sdist - ) where -import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree - , prepareSnapshotTree, snapshotPackage ) -import Distribution.Client.Tar (createTarGzFile) - -import Distribution.Package - ( Package(..) ) -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.Simple.Utils - ( defaultPackageDesc, warn, notice, setupMessage - , createDirectoryIfMissingVerbose, withTempDirectory ) -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 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 tmpTargetDir = srcPref distPref - - -- do some QA - printPackageProblems verbosity pkg - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - setupMessage verbosity "Building source dist for" (packageId pkg') - - _ <- if snapshot - then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - 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) - pps = knownSuffixHandlers - --- |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/cabal-install-0.8.2/Distribution/Client/Tar.hs b/cabal-install-0.8.2/Distribution/Client/Tar.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Tar.hs +++ /dev/null @@ -1,870 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Tar --- Copyright : (c) 2007 Bjorn Bringert, --- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts --- License : BSD3 --- --- Maintainer : duncan@haskell.org --- Portability : portable --- --- Reading, writing and manipulating \"@.tar@\" archive files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Tar ( - -- * High level \"all in one\" operations - createTarGzFile, - extractTarGzFile, - - -- * Converting between internal and external representation - read, - write, - - -- * Packing and unpacking files to\/from internal representation - pack, - unpack, - - -- * Tar entry and associated types - Entry(..), - entryPath, - EntryContent(..), - Ownership(..), - FileSize, - Permissions, - EpochTime, - DevMajor, - DevMinor, - TypeCode, - Format(..), - - -- * Constructing simple entry values - simpleEntry, - fileEntry, - directoryEntry, - - -- * TarPath type - TarPath, - toTarPath, - fromTarPath, - - -- ** Sequences of tar entries - Entries(..), - foldEntries, - unfoldEntries, - mapEntries, - - ) where - -import Data.Char (ord) -import Data.Int (Int64) -import Data.Bits (Bits, shiftL) -import Data.List (foldl') -import Numeric (readOct, showOct) -import Control.Monad (MonadPlus(mplus)) - -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 -import qualified System.FilePath.Windows as FilePath.Windows -import qualified System.FilePath.Posix as FilePath.Posix -import System.Directory - ( getDirectoryContents, doesDirectoryExist, getModificationTime - , getPermissions, createDirectoryIfMissing, copyFile ) -import qualified System.Directory as Permissions - ( Permissions(executable) ) -import System.Posix.Types - ( FileMode ) -import System.Time - ( ClockTime(..) ) -import System.IO - ( IOMode(ReadMode), openBinaryFile, hFileSize ) -import System.IO.Unsafe (unsafeInterleaveIO) - -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 = - BS.writeFile tar . GZip.compress . write =<< pack base [dir] - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir expected tar = - unpack dir . checkTarbomb expected . read . GZip.decompress =<< BS.readFile tar - --- --- * Entry type --- - -type FileSize = Int64 --- | The number of seconds since the UNIX epoch -type EpochTime = Int64 -type DevMajor = Int -type DevMinor = Int -type TypeCode = Char -type Permissions = FileMode - --- | Tar archive entry. --- -data Entry = Entry { - - -- | The path of the file or directory within the archive. This is in a - -- tar-specific form. Use 'entryPath' to get a native 'FilePath'. - entryTarPath :: !TarPath, - - -- | The real content of the entry. For 'NormalFile' this includes the - -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. - entryContent :: !EntryContent, - - -- | File permissions (Unix style file mode). - entryPermissions :: !Permissions, - - -- | The user and group to which this file belongs. - entryOwnership :: !Ownership, - - -- | The time the file was last modified. - entryTime :: !EpochTime, - - -- | The tar format the archive is using. - entryFormat :: !Format - } - --- | Native 'FilePath' of the file or directory within the archive. --- -entryPath :: Entry -> FilePath -entryPath = fromTarPath . entryTarPath - --- | The content of a tar archive entry, which depends on the type of entry. --- --- Portable archives should contain only 'NormalFile' and 'Directory'. --- -data EntryContent = NormalFile ByteString !FileSize - | Directory - | SymbolicLink !LinkTarget - | HardLink !LinkTarget - | CharacterDevice !DevMajor !DevMinor - | BlockDevice !DevMajor !DevMinor - | NamedPipe - | OtherEntryType !TypeCode ByteString !FileSize - -data Ownership = Ownership { - -- | The owner user name. Should be set to @\"\"@ if unknown. - ownerName :: String, - - -- | The owner group name. Should be set to @\"\"@ if unknown. - groupName :: String, - - -- | Numeric owner user id. Should be set to @0@ if unknown. - ownerId :: !Int, - - -- | Numeric owner group id. Should be set to @0@ if unknown. - groupId :: !Int - } - --- | There have been a number of extensions to the tar file format over the --- years. They all share the basic entry fields and put more meta-data in --- different extended headers. --- -data Format = - - -- | This is the classic Unix V7 tar format. It does not support owner and - -- group names, just numeric Ids. It also does not support device numbers. - V7Format - - -- | The \"USTAR\" format is an extension of the classic V7 format. It was - -- later standardised by POSIX. It has some restructions but is the most - -- portable format. - -- - | UstarFormat - - -- | The GNU tar implementation also extends the classic V7 format, though - -- in a slightly different way from the USTAR format. In general for new - -- archives the standard USTAR/POSIX should be used. - -- - | GnuFormat - deriving Eq - --- | @rw-r--r--@ for normal files -ordinaryFilePermissions :: Permissions -ordinaryFilePermissions = 0o0644 - --- | @rwxr-xr-x@ for executable files -executableFilePermissions :: Permissions -executableFilePermissions = 0o0755 - --- | @rwxr-xr-x@ for directories -directoryPermissions :: Permissions -directoryPermissions = 0o0755 - --- | An 'Entry' with all default values except for the file name and type. It --- uses the portable USTAR/POSIX format (see 'UstarHeader'). --- --- You can use this as a basis and override specific fields, eg: --- --- > (emptyEntry name HardLink) { linkTarget = target } --- -simpleEntry :: TarPath -> EntryContent -> Entry -simpleEntry tarpath content = Entry { - entryTarPath = tarpath, - entryContent = content, - entryPermissions = case content of - Directory -> directoryPermissions - _ -> ordinaryFilePermissions, - entryOwnership = Ownership "" "" 0 0, - entryTime = 0, - entryFormat = UstarFormat - } - --- | A tar 'Entry' for a file. --- --- Entry fields such as file permissions and ownership have default values. --- --- You can use this as a basis and override specific fields. For example if you --- need an executable file you could use: --- --- > (fileEntry name content) { fileMode = executableFileMode } --- -fileEntry :: TarPath -> ByteString -> Entry -fileEntry name fileContent = - simpleEntry name (NormalFile fileContent (BS.length fileContent)) - --- | A tar 'Entry' for a directory. --- --- Entry fields such as file permissions and ownership have default values. --- -directoryEntry :: TarPath -> Entry -directoryEntry name = simpleEntry name Directory - --- --- * Tar paths --- - --- | The classic tar format allowed just 100 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 old tar --- programs that only understand the classic format. A classic tar would be --- able to extract the file name and possibly some dir prefix, but not the --- full dir prefix. So the files would end up in the wrong place, but that's --- probably better than ending up with the wrong names too. --- --- So it's understandable but rather annoying. --- --- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective --- of the local path conventions. --- --- * The directory separator between the prefix and name is /not/ stored. --- -data TarPath = TarPath FilePath -- path name, 100 characters max. - FilePath -- path prefix, 155 characters max. - deriving (Eq, Ord) - --- | Convert a 'TarPath' to a native 'FilePath'. --- --- The native 'FilePath' will use the native directory separator but it is not --- otherwise checked for validity or sanity. In particular: --- --- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is --- not valid on Windows. --- --- * The tar path may be an absolute path or may contain @\"..\"@ components. --- For security reasons this should not usually be allowed, but it is your --- responsibility to check for these conditions (eg using 'checkSecurity'). --- -fromTarPath :: TarPath -> FilePath -fromTarPath (TarPath name prefix) = adjustDirectory $ - FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix - ++ FilePath.Posix.splitDirectories name - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name - = FilePath.Native.addTrailingPathSeparator - | otherwise = id - --- | Convert a native 'FilePath' to a 'TarPath'. --- --- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a --- description of the problem with splitting long 'FilePath's. --- -toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for - -- directories a 'TarPath' must always use a trailing @\/@. - -> FilePath -> Either String TarPath -toTarPath isDir = splitLongPath - . addTrailingSep - . FilePath.Posix.joinPath - . FilePath.Native.splitDirectories - where - addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator - | otherwise = id - --- | Take a sanitized path, split on directory separators and try to pack it --- into the 155 + 100 tar file name format. --- --- The 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) - --- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and --- 'HardLink' entry types. --- -newtype LinkTarget = LinkTarget FilePath - deriving (Eq, Ord) - --- | Convert a tar 'LinkTarget' to a native 'FilePath'. --- -fromLinkTarget :: LinkTarget -> FilePath -fromLinkTarget (LinkTarget path) = adjustDirectory $ - FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path - = FilePath.Native.addTrailingPathSeparator - | otherwise = id - --- --- * Entries type --- - --- | A tar archive is a sequence of entries. -data Entries = Next Entry Entries - | Done - | Fail String - -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 --- - --- | This function checks a sequence of tar entries for file name security --- problems. It checks that: --- --- * file paths are not absolute --- --- * file paths do not contain any path components that are \"@..@\" --- --- * file names are valid --- --- These checks are from the perspective of the current OS. That means we check --- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive --- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the --- link target. A failure in any entry terminates the sequence of entries with --- an error. --- -checkSecurity :: Entries -> Entries -checkSecurity = checkEntries checkEntrySecurity - -checkTarbomb :: FilePath -> Entries -> Entries -checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) - -checkEntrySecurity :: Entry -> Maybe String -checkEntrySecurity entry = case entryContent entry of - HardLink link -> check (entryPath entry) - `mplus` check (fromLinkTarget link) - SymbolicLink link -> check (entryPath entry) - `mplus` check (fromLinkTarget link) - _ -> check (entryPath entry) - - where - check name - | not (FilePath.Native.isRelative name) - = Just $ "Absolute file name in tar archive: " ++ show name - - | not (FilePath.Native.isValid name) - = Just $ "Invalid file name in tar archive: " ++ show name - - | any (=="..") (FilePath.Native.splitDirectories name) - = Just $ "Invalid file name in tar archive: " ++ show name - - | otherwise = Nothing - -checkEntryTarbomb :: FilePath -> Entry -> Maybe String -checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing - where - -- Ignore some special entries we will not unpack anyway - nonFilesystemEntry = - case entryContent entry of - OtherEntryType 'g' _ _ -> True --PAX global header - OtherEntryType 'x' _ _ -> True --PAX individual header - _ -> False - -checkEntryTarbomb expectedTopDir entry = - case FilePath.Native.splitDirectories (entryPath entry) of - (topDir:_) | topDir == expectedTopDir -> Nothing - _ -> Just $ "File in tar archive is not in the expected directory " - ++ show expectedTopDir - -checkEntries :: (Entry -> Maybe String) -> Entries -> Entries -checkEntries checkEntry = - mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry)) - --- --- * Reading --- - -read :: ByteString -> Entries -read = unfoldEntries getEntry - -getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) -getEntry bs - | BS.length header < 512 = Left "truncated tar archive" - - -- Tar files end with at least two blocks of all '0'. Checking this serves - -- two purposes. It checks the format but also forces the tail of the data - -- which is necessary to close the file if it came from a lazily read file. - | BS.head bs == 0 = case BS.splitAt 1024 bs of - (end, trailing) - | BS.length end /= 1024 -> Left "short tar trailer" - | not (BS.all (== 0) end) -> Left "bad tar trailer" - | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" - | otherwise -> Right Nothing - - | otherwise = partial $ do - - case (chksum_, format_) of - (Ok chksum, _ ) | correctChecksum header chksum -> return () - (Ok _, Ok _) -> fail "tar checksum error" - _ -> fail "data is not in tar format" - - -- These fields are partial, have to check them - format <- format_; mode <- mode_; - uid <- uid_; gid <- gid_; - size <- size_; mtime <- mtime_; - devmajor <- devmajor_; devminor <- devminor_; - - let content = BS.take size (BS.drop 512 bs) - padding = (512 - size) `mod` 512 - bs' = BS.drop (512 + size + padding) bs - - entry = Entry { - entryTarPath = TarPath name prefix, - entryContent = case typecode of - '\0' -> NormalFile content size - '0' -> NormalFile content size - '1' -> HardLink (LinkTarget linkname) - '2' -> SymbolicLink (LinkTarget linkname) - '3' -> CharacterDevice devmajor devminor - '4' -> BlockDevice devmajor devminor - '5' -> Directory - '6' -> NamedPipe - '7' -> NormalFile content size - _ -> OtherEntryType typecode content size, - entryPermissions = mode, - entryOwnership = Ownership uname gname uid gid, - entryTime = mtime, - entryFormat = format - } - - return (Just (entry, bs')) - - where - header = BS.take 512 bs - - name = getString 0 100 header - mode_ = getOct 100 8 header - uid_ = getOct 108 8 header - gid_ = getOct 116 8 header - size_ = getOct 124 12 header - mtime_ = getOct 136 12 header - chksum_ = getOct 148 8 header - typecode = getByte 156 header - linkname = getString 157 100 header - magic = getChars 257 8 header - uname = getString 265 32 header - gname = getString 297 32 header - devmajor_ = getOct 329 8 header - devminor_ = getOct 337 8 header - prefix = getString 345 155 header --- trailing = getBytes 500 12 header - - format_ = case magic of - "\0\0\0\0\0\0\0\0" -> return V7Format - "ustar\NUL00" -> return UstarFormat - "ustar \NUL" -> return GnuFormat - _ -> fail "tar entry not in a recognised format" - -correctChecksum :: ByteString -> Int -> Bool -correctChecksum header checksum = checksum == checksum' - where - -- sum of all 512 bytes in the header block, - -- treating each byte as an 8-bit unsigned value - checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' - -- treating the 8 bytes of chksum as blank characters. - header' = BS.concat [BS.take 148 header, - BS.Char8.replicate 8 ' ', - BS.drop 156 header] - --- * TAR format primitive input - -getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a -getOct off len header - | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes)) - | null octstr = return 0 - | otherwise = case readOct octstr of - [(x,[])] -> return x - _ -> fail "tar header is malformed (bad numeric encoding)" - where - bytes = getBytes off len header - octstr = BS.Char8.unpack - . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') - . BS.Char8.dropWhile (== ' ') - $ bytes - - -- Some tar programs switch into a binary format when they try to represent - -- field values that will not fit in the required width when using the text - -- octal format. In particular, the UID/GID fields can only hold up to 2^21 - -- while in the binary format can hold up to 2^32. The binary format uses - -- '\128' as the header which leaves 7 bytes. Only the last 4 are used. - parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] = - return $! shiftL (fromIntegral byte3) 24 - + shiftL (fromIntegral byte2) 16 - + shiftL (fromIntegral byte1) 8 - + shiftL (fromIntegral byte0) 0 - parseBinInt _ = fail "tar header uses non-standard number encoding" - -getBytes :: Int64 -> Int64 -> ByteString -> ByteString -getBytes off len = BS.take len . BS.drop off - -getByte :: Int64 -> ByteString -> Char -getByte off bs = BS.Char8.index bs off - -getChars :: Int64 -> Int64 -> ByteString -> String -getChars off len = BS.Char8.unpack . getBytes off len - -getString :: Int64 -> Int64 -> ByteString -> String -getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len - -data Partial a = Error String | Ok a - -partial :: Partial a -> Either String a -partial (Error msg) = Left msg -partial (Ok x) = Right x - -instance Monad Partial where - return = Ok - Error m >>= _ = Error m - Ok x >>= k = k x - fail = Error - --- --- * Writing --- - --- | Create the external representation of a tar archive by serialising a list --- of tar entries. --- --- * The conversion is done lazily. --- -write :: [Entry] -> ByteString -write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] - -putEntry :: Entry -> ByteString -putEntry entry = case entryContent entry of - NormalFile content size -> BS.concat [ header, content, padding size ] - OtherEntryType _ content size -> BS.concat [ header, content, padding size ] - _ -> header - where - header = putHeader entry - padding size = BS.replicate paddingSize 0 - where paddingSize = fromIntegral (negate size `mod` 512) - -putHeader :: Entry -> ByteString -putHeader entry = - BS.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 { - entryTarPath = TarPath name prefix, - entryContent = content, - entryPermissions = permissions, - entryOwnership = ownership, - entryTime = modTime, - entryFormat = format - } = - - concat - [ putString 100 $ name - , putOct 8 $ permissions - , putOct 8 $ ownerId ownership - , putOct 8 $ groupId ownership - , putOct 12 $ contentSize - , putOct 12 $ modTime - , fill 8 $ ' ' -- dummy checksum - , putChar8 $ typeCode - , putString 100 $ linkTarget - ] ++ - case format of - V7Format -> - fill 255 '\NUL' - UstarFormat -> concat - [ putString 8 $ "ustar\NUL00" - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putOct 8 $ deviceMajor - , putOct 8 $ deviceMinor - , putString 155 $ prefix - , fill 12 $ '\NUL' - ] - GnuFormat -> concat - [ putString 8 $ "ustar \NUL" - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putGnuDev 8 $ deviceMajor - , putGnuDev 8 $ deviceMinor - , putString 155 $ prefix - , fill 12 $ '\NUL' - ] - where - (typeCode, contentSize, linkTarget, - deviceMajor, deviceMinor) = case content of - NormalFile _ size -> ('0' , size, [], 0, 0) - Directory -> ('5' , 0, [], 0, 0) - SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0) - HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0) - CharacterDevice major minor -> ('3' , 0, [], major, minor) - BlockDevice major minor -> ('4' , 0, [], major, minor) - NamedPipe -> ('6' , 0, [], 0, 0) - OtherEntryType code _ size -> (code, size, [], 0, 0) - - putGnuDev w n = case content of - CharacterDevice _ _ -> putOct w n - BlockDevice _ _ -> putOct w n - _ -> replicate w '\NUL' - --- * TAR format primitive output - -type FieldWidth = Int - -putString :: FieldWidth -> String -> String -putString n s = take n s ++ fill (n - length s) '\NUL' - ---TODO: check integer widths, eg for large file sizes -putOct :: Integral a => FieldWidth -> a -> String -putOct n x = - let octStr = take (n-1) $ showOct x "" - in fill (n - length octStr - 1) '0' - ++ octStr - ++ putChar8 '\NUL' - -putChar8 :: Char -> String -putChar8 c = [c] - -fill :: FieldWidth -> Char -> String -fill n c = replicate n c - --- --- * Unpacking --- - -unpack :: FilePath -> Entries -> IO () -unpack baseDir entries = unpackEntries [] (checkSecurity entries) - >>= emulateLinks - - where - -- We're relying here on 'checkSecurity' to make sure we're not scribbling - -- files all over the place. - - unpackEntries _ (Fail err) = fail err - unpackEntries links Done = return links - unpackEntries links (Next entry es) = case entryContent entry of - NormalFile file _ -> extractFile path file - >> unpackEntries links es - Directory -> extractDir path - >> unpackEntries links es - HardLink link -> (unpackEntries $! saveLink path link links) es - SymbolicLink link -> (unpackEntries $! saveLink path link links) es - _ -> unpackEntries links es --ignore other file types - where - path = entryPath entry - - extractFile path content = do - -- Note that tar archives do not make sure each directory is created - -- before files they contain, indeed we may have to create several - -- levels of directory. - createDirectoryIfMissing True absDir - BS.writeFile absPath content - where - absDir = baseDir FilePath.Native.takeDirectory path - absPath = baseDir path - - extractDir path = createDirectoryIfMissing True (baseDir path) - - saveLink path link links = seq (length path) - $ seq (length link') - $ (path, link'):links - where link' = fromLinkTarget link - - emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> - let absPath = baseDir relPath - absTarget = FilePath.Native.takeDirectory absPath relLinkTarget - in copyFile absTarget absPath - --- --- * Packing --- - -pack :: FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to pack, relative to the base dir - -> IO [Entry] -pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir - -preparePaths :: FilePath -> [FilePath] -> IO [FilePath] -preparePaths baseDir paths = - fmap concat $ interleave - [ do isDir <- doesDirectoryExist (baseDir path) - if isDir - then do entries <- getDirectoryContentsRecursive (baseDir path) - return (FilePath.Native.addTrailingPathSeparator path - : map (path ) entries) - else return [path] - | path <- paths ] - -packPaths :: FilePath -> [FilePath] -> IO [Entry] -packPaths baseDir paths = - interleave - [ do tarpath <- either fail return (toTarPath isDir relpath) - if isDir then packDirectoryEntry filepath tarpath - else packFileEntry filepath tarpath - | relpath <- paths - , let isDir = FilePath.Native.hasTrailingPathSeparator filepath - filepath = baseDir relpath ] - -interleave :: [IO a] -> IO [a] -interleave = unsafeInterleaveIO . go - where - go [] = return [] - go (x:xs) = do - x' <- x - xs' <- interleave xs - return (x':xs') - -packFileEntry :: FilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry -packFileEntry filepath tarpath = do - mtime <- getModTime filepath - perms <- getPermissions filepath - file <- openBinaryFile filepath ReadMode - size <- hFileSize file - content <- BS.hGetContents file - return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { - entryPermissions = if Permissions.executable perms - then executableFilePermissions - else ordinaryFilePermissions, - entryTime = mtime - } - -packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry -packDirectoryEntry filepath tarpath = do - mtime <- getModTime filepath - return (directoryEntry tarpath) { - entryTime = mtime - } - -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive dir0 = - fmap tail (recurseDirectories dir0 [""]) - -recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] -recurseDirectories _ [] = return [] -recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (base dir) - - files' <- recurseDirectories base (dirs' ++ dirs) - return (dir : 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 - dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry - isDirectory <- doesDirectoryExist (base dirEntry) - if isDirectory - then collect files (dirEntry':dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - -getModTime :: FilePath -> IO EpochTime -getModTime path = do - (TOD s _) <- getModificationTime path - return $! fromIntegral s diff --git a/cabal-install-0.8.2/Distribution/Client/Types.hs b/cabal-install-0.8.2/Distribution/Client/Types.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Types.hs +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - ( PackageName, PackageId, Package(..) - , PackageFixedDeps(..), Dependency ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.PackageDescription - ( GenericPackageDescription, FlagAssignment ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Version - ( VersionRange ) - -import Data.Map (Map) -import Network.URI (URI) -import Distribution.Compat.Exception - ( SomeException ) - -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } - --- | This is the information we get from a @00-index.tar.gz@ hackage index. --- -data AvailablePackageDb = AvailablePackageDb { - packageIndex :: PackageIndex AvailablePackage, - packagePreferences :: Map PackageName VersionRange -} - --- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. --- What is new in 1.8 is that installed packages and dependencies between --- installed packages are now identified by an opaque InstalledPackageId --- rather than a source PackageId. --- --- We should use simply an 'InstalledPackageInfo' here but to ease the --- transition we are temporarily using this variant where we pretend that --- installed packages still specify their deps in terms of PackageIds. --- --- Crucially this means that 'InstalledPackage' can be an instance of --- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance --- of that class. This means we can make 'PackageIndex'es of InstalledPackage --- where as the InstalledPackageInfo now has its own monomorphic index type. --- -data InstalledPackage = InstalledPackage - InstalledPackageInfo - [PackageId] - -instance Package InstalledPackage where - packageId (InstalledPackage pkg _) = packageId pkg -instance PackageFixedDeps InstalledPackage where - depends (InstalledPackage _ deps) = deps - --- | 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 - [PackageId] -- 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 :: PackageId, - 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 PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | InstallFailed SomeException -data BuildSuccess = BuildOk DocsResult TestsResult - -data DocsResult = DocsNotTried | DocsFailed | DocsOk -data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/cabal-install-0.8.2/Distribution/Client/Unpack.hs b/cabal-install-0.8.2/Distribution/Client/Unpack.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Unpack.hs +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Unpack --- Copyright : (c) Andrea Vezzosi 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Unpack ( - - -- * Commands - unpack, - - ) where - -import Distribution.Package - ( PackageId, packageId, Dependency(..) ) -import Distribution.Client.PackageIndex as PackageIndex (lookupDependency) -import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault) -import Distribution.Simple.Utils - ( notice, die ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Text(display) -import Distribution.Version - ( anyVersion, intersectVersionRanges ) - -import Distribution.Client.Setup(UnpackFlags(unpackVerbosity, - unpackDestDir)) -import Distribution.Client.Types(UnresolvedDependency(..), - Repo, AvailablePackageSource(..), - AvailablePackage(AvailablePackage), - AvailablePackageDb(AvailablePackageDb)) -import Distribution.Client.Fetch(fetchPackage) -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils as IndexUtils - (getAvailablePackages, disambiguateDependencies) - -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) -import Control.Monad - ( unless, when ) -import Data.Ord (comparing) -import Data.List(maximumBy) -import System.FilePath - ( (), addTrailingPathSeparator ) -import qualified Data.Map as Map - -unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO () -unpack flags repos deps - | null deps = notice verbosity - "No packages requested. Nothing to do." - | otherwise = do - db@(AvailablePackageDb available _) - <- getAvailablePackages verbosity repos - deps' <- fmap (map dependency) - . IndexUtils.disambiguateDependencies available - . map toUnresolved $ deps - - let pkgs = resolvePackages db deps' - - unless (null prefix) $ - createDirectoryIfMissing True prefix - - flip mapM_ pkgs $ \pkg -> - case pkg of - - Left (Dependency name ver) -> - die $ "There is no available version of " ++ display name - ++ " that satisfies " ++ display ver - - Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do - pkgPath <- fetchPackage verbosity repo pkgid - unpackPackage verbosity prefix pkgid pkgPath - - Right (AvailablePackage _ _ LocalUnpackedPackage) -> - error "Distribution.Client.Unpack.unpack: the impossible happened." - where - verbosity = fromFlag (unpackVerbosity flags) - prefix = fromFlagOrDefault "" (unpackDestDir flags) - toUnresolved d = UnresolvedDependency d [] - -unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () -unpackPackage verbosity prefix pkgid pkgPath = do - let pkgdirname = display pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ - "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - -resolvePackages :: AvailablePackageDb - -> [Dependency] - -> [Either Dependency AvailablePackage] -resolvePackages (AvailablePackageDb available prefs) deps = - map (\d -> best d (candidates d)) deps - where - candidates dep@(Dependency name ver) = - let [x,y] = map (PackageIndex.lookupDependency available) - [ Dependency name - (maybe anyVersion id (Map.lookup name prefs) - `intersectVersionRanges` ver) - , dep ] - in if null x then y else x - best d [] = Left d - best _ xs = Right $ maximumBy (comparing packageId) xs - diff --git a/cabal-install-0.8.2/Distribution/Client/Update.hs b/cabal-install-0.8.2/Distribution/Client/Update.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Update.hs +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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(..), AvailablePackageDb(..) ) -import Distribution.Client.Fetch - ( downloadIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.IndexUtils - ( getAvailablePackages ) -import qualified Paths_cabal_install - ( version ) - -import Distribution.Package - ( PackageName(..), packageVersion ) -import Distribution.Version - ( anyVersion, withinRange ) -import Distribution.Simple.Utils - ( warn, notice, writeFileAtomic ) -import Distribution.Verbosity - ( Verbosity ) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Codec.Compression.GZip as GZip (decompress) -import qualified Data.Map as Map -import System.FilePath (dropExtension) -import Data.Maybe (fromMaybe) -import Control.Monad (when) - --- | 'update' downloads the package list from all known servers -update :: Verbosity -> [Repo] -> IO () -update verbosity [] = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." -update verbosity repos = do - mapM_ (updateRepo verbosity) repos - checkForSelfUpgrade verbosity repos - -updateRepo :: Verbosity -> Repo -> IO () -updateRepo verbosity repo = case repoKind repo of - Right LocalRepo -> return () - Left remoteRepo -> do - notice verbosity $ "Downloading the latest package list from " - ++ remoteRepoName remoteRepo - indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) - writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack - . GZip.decompress - =<< BS.readFile indexPath - -checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () -checkForSelfUpgrade verbosity repos = do - AvailablePackageDb available prefs <- getAvailablePackages verbosity repos - - let self = PackageName "cabal-install" - preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) - currentVersion = Paths_cabal_install.version - laterPreferredVersions = - [ packageVersion pkg - | pkg <- PackageIndex.lookupPackageName available self - , let version = packageVersion pkg - , version > currentVersion - , version `withinRange` preferredVersionRange ] - - when (not (null laterPreferredVersions)) $ - notice verbosity $ - "Note: there is a new version of cabal-install available.\n" - ++ "To upgrade, run: cabal install cabal-install" - diff --git a/cabal-install-0.8.2/Distribution/Client/Upload.hs b/cabal-install-0.8.2/Distribution/Client/Upload.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Upload.hs +++ /dev/null @@ -1,177 +0,0 @@ --- 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.TCP (HandleStream) -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, takeFileName) -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 - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap Password getLine - putStrLn "" - return passwd - -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 (HandleStream String) () - -> 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 contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> notice verbosity $ rspBody resp - _ -> debug verbosity $ rspBody resp - -mkRequest :: URI -> FilePath -> IO (Request String) -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=\""++takeFileName 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/cabal-install-0.8.2/Distribution/Client/Utils.hs b/cabal-install-0.8.2/Distribution/Client/Utils.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Utils.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Distribution.Client.Utils where - -import Data.List - ( sortBy, groupBy ) -import System.Directory - ( doesFileExist, getModificationTime - , getCurrentDirectory, setCurrentDirectory ) -import qualified Control.Exception as Exception - ( finally ) - --- | 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 - --- | 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) - --- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old diff --git a/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# 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/cabal-install-0.8.2/Distribution/Compat/Exception.hs b/cabal-install-0.8.2/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.Exception ( - SomeException, - onException, - catchIO, - handleIO, - catchExit, - throwIOIO - ) where - -import System.Exit -import qualified Control.Exception as Exception -#if MIN_VERSION_base(4,0,0) -import Control.Exception (SomeException) -#else -import Control.Exception (Exception) -type SomeException = Exception -#endif - -onException :: IO a -> IO b -> IO a -#if MIN_VERSION_base(4,0,0) -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif - -throwIOIO :: Exception.IOException -> IO a -#if MIN_VERSION_base(4,0,0) -throwIOIO = Exception.throwIO -#else -throwIOIO = Exception.throwIO . Exception.IOException -#endif - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchIO = Exception.catch -#else -catchIO = Exception.catchJust Exception.ioErrors -#endif - -handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchExit = Exception.catch -#else -catchExit = Exception.catchJust exitExceptions - where exitExceptions (Exception.ExitException ee) = Just ee - exitExceptions _ = Nothing -#endif diff --git a/cabal-install-0.8.2/LICENSE b/cabal-install-0.8.2/LICENSE deleted file mode 100644 --- a/cabal-install-0.8.2/LICENSE +++ /dev/null @@ -1,34 +0,0 @@ -Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, - Lemmih, Paolo Martini, Don Stewart, - Duncan Coutts -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-install-0.8.2/Paths_cabal_install.hs b/cabal-install-0.8.2/Paths_cabal_install.hs deleted file mode 100644 --- a/cabal-install-0.8.2/Paths_cabal_install.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Paths_cabal_install ( - version, - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,8,2], versionTags = []} diff --git a/cabal-install-0.8.2/cabal-install.cabal b/cabal-install-0.8.2/cabal-install.cabal deleted file mode 100644 --- a/cabal-install-0.8.2/cabal-install.cabal +++ /dev/null @@ -1,122 +0,0 @@ -Name: cabal-install -Version: 0.8.2 -Synopsis: The command-line interface for Cabal and Hackage. -Description: - The \'cabal\' command-line program simplifies the process of managing - Haskell software by automating the fetching, configuration, compilation - and installation of Haskell libraries and programs. -homepage: http://www.haskell.org/cabal/ -bug-reports: http://hackage.haskell.org/trac/hackage/ -License: BSD3 -License-File: LICENSE -Author: Lemmih - Paolo Martini - 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-2009 Duncan Coutts -Category: Distribution -Build-type: Simple -Extra-Source-Files: README bash-completion/cabal bootstrap.sh -Cabal-Version: >= 1.6 -Tested-With: GHC==6.6.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.1 - -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal-install/ - -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-install-0.8/ - tag: 0.8.2 - -flag old-base - description: Old, monolithic base - default: False - -flag bytestring-in-base - -Executable cabal - Main-Is: Main.hs - -- We want assertion checking on even if people build with -O - -- although it is expensive, we want to catch problems early: - ghc-options: -Wall -fno-ignore-asserts - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - Other-Modules: - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.Config - Distribution.Client.Configure - 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.Haddock - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.Init - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Types - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.List - Distribution.Client.PackageIndex - Distribution.Client.PackageUtils - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SrcDist - Distribution.Client.Tar - Distribution.Client.Types - Distribution.Client.Unpack - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.Win32SelfUpgrade - Distribution.Compat.Exception - Paths_cabal_install - - build-depends: base >= 2 && < 5, - Cabal >= 1.8 && < 1.9, - filepath >= 1.0, - network >= 1 && < 3, - HTTP >= 4000.0.2 && < 4001, - zlib >= 0.4 && < 0.6, - time >= 1.1 && < 1.2 - - if flag(old-base) - build-depends: base < 3 - else - build-depends: base >= 3, - process >= 1 && < 1.1, - directory >= 1 && < 1.1, - pretty >= 1 && < 1.1, - random >= 1 && < 1.1, - containers >= 0.1 && < 0.4, - array >= 0.1 && < 0.4, - old-time >= 1 && < 1.1 - - if flag(bytestring-in-base) - build-depends: base >= 2.0 && < 2.2 - else - build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9 - - if os(windows) - build-depends: Win32 >= 2 && < 3 - cpp-options: -DWIN32 - else - build-depends: unix >= 1.0 && < 2.5 - extensions: CPP diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,311 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) ) +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(..), PackageName(..), 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 + deriving Eq + +data Outcome = NotTried | Failed | Ok + deriving Eq + +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 + convertInstallOutcome = case result of + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + 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 + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (PackageName "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 + +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 = Disp.render . ppFields 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/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ) + +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( groupBy, sortBy ) +import Data.Maybe + ( catMaybes ) +import System.FilePath + ( (), takeDirectory ) +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 :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () +storeLocal templates reports = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : BuildReport.show r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + (BuildReport.compiler report) + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan plan = catMaybes + . map (fromPlanPackage platform comp) + . InstallPlan.toList + $ plan + where platform = InstallPlan.planPlatform plan + comp = InstallPlan.planCompiler plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe (BuildReport, Repo) +fromPlanPackage (Platform arch os) 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/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + ) where + +import qualified Distribution.Text as Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse + ( pfail, munch1 ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( text ) + +import Data.Char as Char + ( isAlpha, toLower ) + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Show) + +instance Text.Text ReportLevel where + disp NoReports = Disp.text "none" + disp AnonymousReports = Disp.text "anonymous" + disp DetailedReports = Disp.text "detailed" + parse = do + name <- Parse.munch1 Char.isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> Parse.pfail + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,71 @@ +{-# 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.TCP (HandleStream) +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 (HandleStream BuildLog) () +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 (HandleStream BuildLog) 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 (HandleStream BuildLog) () +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/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- 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.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( defaultPackageDesc, toUTF8, wrapText ) + +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:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + putStrLn "The following warnings are likely affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + putStrLn "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + putStrLn "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + 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) + + where + printCheckMessages = mapM_ (putStrLn . format . explanation) + format = toUTF8 . wrapText . ("* "++) diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs @@ -0,0 +1,519 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + defaultConfigFile, + defaultCacheDir, + defaultLogsDir, + ) where + + +import Distribution.Client.Types + ( RemoteRepo(..), Username(..), Password(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , showRepo, parseRepo ) + +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , installDirsOptions + , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate ) +import Distribution.ParseUtils + ( FieldDescr(..), liftField + , ParseResult(..), locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, parseFilePathQ, parseTokenQ ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) +import qualified Distribution.Text as Text + ( Text(..) ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) + , viewAsFieldDescr ) +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Utils + ( notice, warn, lowercase ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.List + ( partition, find ) +import Data.Maybe + ( fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( when, foldM, liftM ) +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, empty, isEmpty, nest ) +import Text.PrettyPrint.HughesPJ + ( (<>), (<+>), ($$), ($+$) ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory ) +import Network.URI + ( URI(..), URIAuth(..) ) +import System.FilePath + ( (), takeDirectory ) +import System.Environment + ( getEnvironment ) +import System.IO.Error + ( isDoesNotExistError ) + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig { + savedGlobalFlags :: GlobalFlags, + savedInstallFlags :: InstallFlags, + savedConfigureFlags :: ConfigFlags, + savedConfigureExFlags :: ConfigExFlags, + savedUserInstallDirs :: InstallDirs (Flag PathTemplate), + savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), + savedUploadFlags :: UploadFlags + } + +instance Monoid SavedConfig where + mempty = SavedConfig { + savedGlobalFlags = mempty, + savedInstallFlags = mempty, + savedConfigureFlags = mempty, + savedConfigureExFlags = mempty, + savedUserInstallDirs = mempty, + savedGlobalInstallDirs = mempty, + savedUploadFlags = mempty + } + mappend a b = SavedConfig { + savedGlobalFlags = combine savedGlobalFlags, + savedInstallFlags = combine savedInstallFlags, + savedConfigureFlags = combine savedConfigureFlags, + savedConfigureExFlags = combine savedConfigureExFlags, + 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 + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + }, + savedGlobalFlags = mempty { + globalLogsDir = toFlag logsDir, + globalWorldFile = toFlag worldFile + } + } + +-- | 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 + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = [defaultRemoteRepo], + globalWorldFile = toFlag worldFile + }, + savedInstallFlags = mempty { + installSummaryFile = [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag AnonymousReports + } + } + +--TODO: misleading, there's no way to override this default +-- either make it possible or rename to simply getCabalDir. +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" + +-- | Default position of the world file +defaultWorldFile :: IO FilePath +defaultWorldFile = do + dir <- defaultCabalDir + return $ dir "world" + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +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 + let sources = [ + ("commandline option", return . flagToMaybe $ configFileFlag), + ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment), + ("default config file", Just `liftM` defaultConfigFile) ] + + getSource [] = error "no config file path candidate found." + getSource ((msg,action): xs) = + action >>= maybe (getSource xs) (return . (,) msg) + + (source, configFile) <- getSource sources + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ "Config file path source is " ++ source ++ "." + notice verbosity $ "Config file " ++ configFile ++ " not found." + notice verbosity $ "Writing default configuration to " ++ configFile + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + writeConfigFile configFile commentConf initialConf + return initialConf + 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 ++ ":\n" ++ 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 $ explanation ++ showConfigWithComments comments vals ++ "\n" + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"","" + ] + +-- | 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, + savedConfigureExFlags = defaultConfigExFlags, + 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 liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "configure-option"] ++ map fieldName installDirsFields) + + --FIXME: this is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleField "compiler" + (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs) + [] [] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "reinstall", "only"] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check"] [] + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + optional = Parse.option mempty . fmap toFlag + +-- 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 }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = 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 + let user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (user, global) <- foldM parseSections (user0, global0) 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 + diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + ) where + +import Data.Monoid + ( Monoid(mempty) ) +import qualified Data.Map as Map + +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress + , PackageConstraint(..) + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) + , Progress(..), foldProgress, ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) +import Distribution.Client.Types as Available + ( AvailablePackage(..), AvailablePackageSource(..), Repo(..) + , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId) + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration ) +import Distribution.Simple.Setup + ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Utils + ( defaultPackageDesc ) +import Distribution.Package + ( PackageName, packageName, packageVersion + , Package(..), Dependency(..), thisPackageVersion ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( VersionRange, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, die ) +import Distribution.System + ( Platform, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( Verbosity ) + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repos comp conf + configFlags configExFlags extraArgs = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + available <- getAvailablePackages verbosity repos + + progress <- planLocalPackage verbosity comp configFlags configExFlags + installed available + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> do + info verbosity message + setupWrapper verbosity (setupScriptOptions installed) Nothing + configureCommand (const configFlags) extraArgs + + Right installPlan -> case InstallPlan.ready installPlan of + [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] -> + configurePackage verbosity + (InstallPlan.planPlatform installPlan) + (InstallPlan.planCompiler installPlan) + (setupScriptOptions installed) + configFlags pkg extraArgs + + _ -> die $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion + (flagToMaybe (configCabalVersion configExFlags)), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else packageDBs ++ [UserPackageDB], + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> ConfigFlags -> ConfigExFlags + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> IO (Progress String String InstallPlan) +planLocalPackage verbosity comp configFlags configExFlags installed + (AvailablePackageDb _ availablePrefs) = 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 mempty + installed' = PackageIndex.deletePackageId (packageId localPkg) installed + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage Nothing + } + targets = [packageName pkg] + constraints = [PackageVersionConstraint (packageName pkg) + (thisVersion (packageVersion pkg)) + ,PackageFlagsConstraint (packageName pkg) + (configConfigurationsFlags configFlags)] + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs PreferLatestForSelected + availablePrefs configExFlags + + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available' preferences constraints targets + + +mergePackagePrefs :: PackagesPreferenceDefault + -> Map.Map PackageName VersionRange + -> ConfigExFlags + -> PackagesPreference +mergePackagePrefs defaultPref availablePrefs configExFlags = + PackagesPreference defaultPref $ + -- The preferences that come from the hackage index + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + -- additional preferences from the config file or command line + ++ [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + +-- | 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. +-- +configurePackage :: Verbosity + -> Platform -> CompilerId + -> SetupScriptOptions + -> ConfigFlags + -> ConfiguredPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags extraArgs + + where + configureFlags = filterConfigureFlags configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps, + configVerbosity = toFlag verbosity + } + + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs @@ -0,0 +1,318 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ( + module Distribution.Client.Dependency.Types, + resolveDependencies, + resolveDependenciesWithProgress, + + resolveAvailablePackages, + + dependencyConstraints, + dependencyTargets, + + PackagesPreference(..), + PackagesPreferenceDefault(..), + PackagePreference(..), + + upgradableDependencies, + ) where + +import Distribution.Client.Dependency.TopDown (topDownResolver) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), packageVersion, packageName + , Dependency(Dependency), Package(..), PackageFixedDeps(..) ) +import Distribution.Version + ( VersionRange, anyVersion, orLaterVersion + , isAnyVersion, withinRange, simplifyVersionRange ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils (comparing) +import Distribution.Client.Utils (mergeBy, MergeResult(..)) +import Distribution.Text + ( display ) + +import Data.List (maximumBy) +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) +import Control.Exception (assert) + +defaultResolver :: DependencyResolver +defaultResolver = topDownResolver + +-- | Global policy for the versions of all packages. +-- +data PackagesPreference = PackagesPreference + PackagesPreferenceDefault + [PackagePreference] + +dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint] +dependencyConstraints deps = + [ PackageVersionConstraint name versionRange + | UnresolvedDependency (Dependency name versionRange) _ <- deps + , not (isAnyVersion versionRange) ] + + ++ [ PackageFlagsConstraint name flags + | UnresolvedDependency (Dependency name _) flags <- deps + , not (null flags) ] + +dependencyTargets :: [UnresolvedDependency] -> [PackageName] +dependencyTargets deps = + [ name | UnresolvedDependency (Dependency name _) _ <- deps ] + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | 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 + +data PackagePreference + = PackageVersionPreference PackageName VersionRange + | PackageInstalledPreference PackageName InstalledPreference + +resolveDependencies :: Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Either String InstallPlan +resolveDependencies platform comp installed available + preferences constraints targets = + foldProgress (flip const) Left Right $ + resolveDependenciesWithProgress + platform comp installed available + preferences constraints targets + +resolveDependenciesWithProgress :: Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Progress String String InstallPlan +resolveDependenciesWithProgress platform comp installed available + pref constraints targets + -- TODO: the top down resolver chokes on the base constraints + -- below when there are no targets and thus no dep on base. + -- Need to refactor contraints separate from needing packages. + | null targets = return (toPlan []) + | otherwise = + let installed' = hideBrokenPackages installed + -- If the user is not explicitly asking to upgrade base then lets + -- prevent that from happening accidentally since it is usually not what + -- you want and it probably does not work anyway. We do it by adding a + -- constraint to only pick an installed version of base and ghc-prim. + extraConstraints = + [ PackageInstalledConstraint pkgname + | all (/=PackageName "base") targets + , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] + , not (null (PackageIndex.lookupPackageName installed pkgname)) ] + preferences = interpretPackagesPreference (Set.fromList targets) pref + in fmap toPlan + $ defaultResolver platform comp installed' available + preferences (extraConstraints ++ constraints) targets + + where + toPlan pkgs = + case InstallPlan.new platform 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 + +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 + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreference + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected (PackagesPreference defaultPref prefs) = + \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) + + where + versionPref pkgname = + fromMaybe anyVersion (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromList + [ (pkgname, pref) + | PackageVersionPreference pkgname pref <- prefs ] + + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> \_ -> PreferLatest + PreferAllInstalled -> \_ -> 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 + +-- ------------------------------------------------------------ +-- * Simple resolver that ignores dependencies +-- ------------------------------------------------------------ + +-- | A simplistic method of resolving a list of target package names to +-- available packages. +-- +-- Specifically, it does not consider package dependencies at all. Unlike +-- 'resolveDependencies', no attempt is made to ensure that the selected +-- packages have dependencies that are satisfiable or consistent with +-- each other. +-- +-- It is suitable for tasks such as selecting packages to download for user +-- inspection. It is not suitable for selecting packages to install. +-- +-- Note: if no installed package index is available, it is ok to pass 'mempty'. +-- It simply means preferences for installed packages will be ignored. +-- +resolveAvailablePackages + :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Either [ResolveNoDepsError] [AvailablePackage] +resolveAvailablePackages installed available preferences constraints targets = + collectEithers (map selectPackage targets) + where + selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + + where + -- Constraints + requiredVersions = packageConstraints pkgname + pkgDependency = Dependency pkgname requiredVersions + choices = PackageIndex.lookupDependency available pkgDependency + + -- Preferences + PackagePreferences preferredVersions preferInstalled + = packagePreferences pkgname + + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref = case preferInstalled of + PreferLatest -> const False + PreferInstalled -> isJust . PackageIndex.lookupPackageId installed + . packageId + versionPref pkg = packageVersion pkg `withinRange` preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap = + Map.fromList [ (name, range) + | PackageVersionConstraint name range <- constraints ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference (Set.fromList targets) preferences + + +collectEithers :: [Either a b] -> Either [a] [b] +collectEithers = collect . partitionEithers + where + collect ([], xs) = Right xs + collect (errs,_) = Left errs + partitionEithers :: [Either a b] -> ([a],[b]) + partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) + +-- | Errors for 'resolveWithoutDependencies'. +-- +data ResolveNoDepsError = + + -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange + +instance Show ResolveNoDepsError where + show (ResolveUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ display (simplifyVersionRange ver) + +-- ------------------------------------------------------------ +-- * Finding upgradable packages +-- ------------------------------------------------------------ + +-- | Given the list of installed packages and available packages, figure +-- out which packages can be upgraded. +-- +upgradableDependencies :: PackageIndex InstalledPackage + -> 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/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs @@ -0,0 +1,776 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) + +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName + , Dependency(Dependency), thisPackageVersion, notThisPackageVersion + , PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( PackageDescription(buildDepends) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Version + ( VersionRange, anyVersion, withinRange, simplifyVersionRange + , UpperBound(..), asVersionIntervals ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) +import Data.Maybe + ( fromJust, fromMaybe, catMaybes ) +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 +import Control.Exception + ( assert ) + +-- ------------------------------------------------------------ +-- * Search state types +-- ------------------------------------------------------------ + +type Constraints = Constraints.Constraints + InstalledPackageEx 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 -> PackagePreferences) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) + +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = + case [ choice | [choice] <- choices ] of + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') + where + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice + where + topSortNumber choice = case fst (head choice) of + InstalledOnly (InstalledPackageEx _ i _) -> i + AvailableOnly (UnconfiguredPackage _ i _) -> i + InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i + + bestByPref pkgname = case packageInstalledPreference of + PreferLatest -> + comparing (\(p,_) -> ( isPreferred p, packageId p)) + PreferInstalled -> + comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) + where + isInstalled (AvailableOnly _) = False + isInstalled _ = True + isPreferred p = packageVersion p `withinRange` preferredVersions + (PackagePreferences preferredVersions packageInstalledPreference) + = pref pkgname + + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + +-- ------------------------------------------------------------ +-- * Generate a search tree +-- ------------------------------------------------------------ + +type ConfigurePackage = PackageIndex SelectablePackage + -> SelectablePackage + -> Either [Dependency] SelectedPackage + +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) + +searchSpace :: ConfigurePackage + -> Constraints + -> SelectedPackages + -> SelectionChanges + -> Set PackageName + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + ChoiceNode (selected, constraints, changes) + [ [ (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' -> case constrainDeps pkg' newDeps constraints [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = + case Constraints.isPaired constraints (packageId pkg) of + Nothing -> [pkg'] + Just pkgid' -> [pkg', pkg''] + where + Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) + (PackageIndex.lookupPackageId available pkgid') + + newPkgs = [ name' + | dep <- newDeps + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = concatMap packageConstraints newSelected + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + +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 (InstalledPackageEx _ _ deps) = + [ TaggedDependency InstalledConstraint (thisPackageVersion dep) + | dep <- deps ] + availableConstraints (SemiConfiguredPackage _ _ deps) = + [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] + +constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints + -> [PackageIdentifier] + -> Either Failure (Constraints, [PackageIdentifier]) +constrainDeps pkg [] cs discard = + case addPackageSelectConstraint (packageId pkg) cs of + Satisfiable cs' discard' -> Right (cs', discard' ++ discard) + _ -> impossible +constrainDeps pkg (dep:deps) cs discard = + case addPackageDependencyConstraint (packageId pkg) dep cs of + Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) + Unsatisfiable -> impossible + ConflictsWith conflicts -> + Left (DependencyConflict pkg dep conflicts) + +-- ------------------------------------------------------------ +-- * The main algorithm +-- ------------------------------------------------------------ + +search :: ConfigurePackage + -> (PackageName -> PackagePreferences) + -> 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' :: Platform -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress Log Failure [PlanPackage] +topDownResolver' platform comp installed available + preferences constraints targets = + fmap (uncurry finalise) + . (\cs -> search configure preferences cs initialPkgNames) + =<< addTopLevelConstraints constraints constraintSet + + where + configure = configurePackage platform comp + constraintSet :: Constraints + constraintSet = Constraints.empty + (annotateInstalledPackages topSortNumber installed') + (annotateAvailablePackages constraints topSortNumber available') + (installed', available') = selectNeededSubset installed available + initialPkgNames + topSortNumber = topologicalSortNumbering installed' available' + + initialPkgNames = Set.fromList targets + + finalise selected' constraints' = + PackageIndex.allPackages + . fst . improvePlan installed' constraints' + . PackageIndex.fromList + $ finaliseSelectedPackages preferences selected' constraints' + +addTopLevelConstraints :: [PackageConstraint] -> Constraints + -> Progress a Failure Constraints +addTopLevelConstraints [] cs = Done cs +addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs = + addTopLevelConstraints deps cs + +addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs = + case addTopLevelVersionConstraint pkg ver cs of + Satisfiable cs' _ -> + addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) + + ConflictsWith conflicts -> + Fail (TopLevelVersionConstraintConflict pkg ver conflicts) + +addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs = + case addTopLevelInstalledConstraint pkg cs of + Satisfiable cs' _ -> addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelInstallConstraintUnsatisfiable pkg) + + ConflictsWith conflicts -> + Fail (TopLevelInstallConstraintConflict pkg conflicts) + +configurePackage :: Platform -> CompilerId -> ConfigurePackage +configurePackage platform 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 dependencySatisfiable + platform comp [] p of + Left missing -> Left missing + Right (pkg, flags') -> Right $ + SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) + + dependencySatisfiable = not . null . PackageIndex.lookupDependency available + +-- | Annotate each installed packages with its set of transative dependencies +-- and its topological sort number. +-- +annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) + -> PackageIndex InstalledPackage + -> PackageIndex InstalledPackageEx +annotateInstalledPackages dfsNumber installed = PackageIndex.fromList + [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + | pkg <- PackageIndex.allPackages installed ] + where + transitiveDepends :: InstalledPackage -> [PackageIdentifier] + transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph + . fromJust . toVertex . packageId + (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed + + +-- | Annotate each available packages with its topological sort number and any +-- user-supplied partial flag assignment. +-- +annotateAvailablePackages :: [PackageConstraint] + -> (PackageName -> TopologicalSortNumber) + -> PackageIndex AvailablePackage + -> PackageIndex UnconfiguredPackage +annotateAvailablePackages constraints 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) + | PackageFlagsConstraint name flags <- constraints ] + +-- | 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 InstalledPackage + -> 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 InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex AvailablePackage) +selectNeededSubset installed available = select mempty mempty + where + select :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,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 = -- we filter out packages already included in the indexes + -- this avoids an infinite loop if a package depends on itself + -- like base-3.0.3.0 with base-4.0.0.0 + filter notAlreadyIncluded + $ [ packageName dep + | pkg <- moreInstalled + , dep <- depends pkg ] + ++ [ name + | AvailablePackage _ pkg _ <- moreAvailable + , Dependency name _ <- + buildDepends (flattenPackageDescription pkg) ] + installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled + available'' = foldl' (flip PackageIndex.insert) available' moreAvailable + remaining'' = foldl' (flip Set.insert) remaining' moreRemaining + notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name) + && null (PackageIndex.lookupPackageName available' name) + +-- ------------------------------------------------------------ +-- * Post processing the solution +-- ------------------------------------------------------------ + +finaliseSelectedPackages :: (PackageName -> PackagePreferences) + -> SelectedPackages + -> Constraints + -> [PlanPackage] +finaliseSelectedPackages pref selected constraints = + map finaliseSelected (PackageIndex.allPackages selected) + where + remainingChoices = Constraints.choices constraints + finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg + finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing 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 (Just ipkg) apkg + + finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg + finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags deps') + where + deps' = map (packageId . pickRemaining mipkg) deps + + pickRemaining mipkg dep@(Dependency _name versionRange) = + case PackageIndex.lookupDependency remainingChoices dep of + [] -> impossible + [pkg'] -> pkg' + remaining -> assert (checkIsPaired remaining) + $ maximumBy bestByPref remaining + where + -- We order candidate packages to pick for a dependency by these + -- three factors. The last factor is just highest version wins. + bestByPref = + comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) + -- Is the package already used by the installed version of this + -- package? If so we should pick that first. This stops us from doing + -- silly things like deciding to rebuild haskell98 against base 3. + isCurrent = case mipkg :: Maybe InstalledPackageEx of + Nothing -> \_ -> False + Just ipkg -> \p -> packageId p `elem` depends ipkg + -- If there is no upper bound on the version range then we apply a + -- preferred version acording to the hackage or user's suggested + -- version constraints. TODO: distinguish hacks from prefs + bounded = boundedAbove versionRange + isPreferred p + | bounded = True -- any constant will do + | otherwise = packageVersion p `withinRange` preferredVersions + where (PackagePreferences preferredVersions _) = pref (packageName p) + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + -- We really only expect to find more than one choice remaining when + -- we're finalising a dependency on a paired package. + checkIsPaired [p1, p2] = + case Constraints.isPaired constraints (packageId p1) of + Just p2' -> packageId p2' == packageId p2 + Nothing -> False + checkIsPaired _ = False + +-- | Improve an existing installation plan by, where possible, swapping +-- packages we plan to install with ones that are already installed. +-- This may add additional constraints due to the dependencies of installed +-- packages on other installed packages. +-- +improvePlan :: PackageIndex InstalledPackage + -> Constraints + -> PackageIndex PlanPackage + -> (PackageIndex PlanPackage, Constraints) +improvePlan installed constraints0 selected0 = + foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) + where + improve (selected, constraints) = fromMaybe (selected, constraints) + . improvePkg selected constraints + + -- 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 constraints pkgid = do + Configured pkg <- PackageIndex.lookupPackageId selected pkgid + ipkg <- PackageIndex.lookupPackageId installed pkgid + guard $ all (isInstalled selected) (depends pkg) + tryInstalled selected constraints [ipkg] + + isInstalled selected pkgid = + case PackageIndex.lookupPackageId selected pkgid of + Just (PreExisting _) -> True + _ -> False + + tryInstalled :: PackageIndex PlanPackage -> Constraints + -> [InstalledPackage] + -> Maybe (PackageIndex PlanPackage, Constraints) + tryInstalled selected constraints [] = Just (selected, constraints) + tryInstalled selected constraints (pkg:pkgs) = + case constraintsOk (packageId pkg) (depends pkg) constraints of + Nothing -> Nothing + Just constraints' -> tryInstalled selected' constraints' pkgs' + where + selected' = PackageIndex.insert (PreExisting pkg) selected + pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs + notSelected pkgid = + case (PackageIndex.lookupPackageId installed pkgid + ,PackageIndex.lookupPackageId selected pkgid) of + (Just pkg', Nothing) -> Just pkg' + _ -> Nothing + + constraintsOk _ [] constraints = Just constraints + constraintsOk pkgid (pkgid':pkgids) constraints = + case addPackageDependencyConstraint pkgid dep constraints of + Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' + _ -> Nothing + where + dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid') + + reverseTopologicalOrder :: PackageFixedDeps pkg + => PackageIndex pkg -> [PackageIdentifier] + reverseTopologicalOrder index = map (packageId . toPkg) + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkg, _) = PackageIndex.dependencyGraph index + +-- ------------------------------------------------------------ +-- * Adding and recording constraints +-- ------------------------------------------------------------ + +addPackageSelectConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageSelectConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) + reason = SelectedOther pkgid + +addPackageExcludeConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageExcludeConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint + (notThisPackageVersion pkgid) + reason = ExcludedByConfigureFail + +addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageDependencyConstraint pkgid dep constraints = + Constraints.constrain dep reason constraints + where + reason = ExcludedByPackageDependency pkgid dep + +addTopLevelVersionConstraint :: PackageName -> VersionRange + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelVersionConstraint pkg ver constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg ver + taggedDep = TaggedDependency NoInstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +addTopLevelInstalledConstraint :: PackageName + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelInstalledConstraint pkg constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg anyVersion + taggedDep = TaggedDependency InstalledConstraint 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 " ++ displayDep (untagDependency dep) +showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = + display pkgid ++ " was excluded because of the top level dependency " ++ + displayDep dep + + +-- ------------------------------------------------------------ +-- * Logging progress and failures +-- ------------------------------------------------------------ + +data Log = Select [SelectedPackage] [PackageIdentifier] +data Failure + = ConfigureFailed + SelectablePackage + [(Dependency, [(PackageIdentifier, [ExclusionReason])])] + | DependencyConflict + SelectedPackage TaggedDependency + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintConflict + PackageName VersionRange + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintUnsatisfiable + PackageName VersionRange + | TopLevelInstallConstraintConflict + PackageName + [(PackageIdentifier, [ExclusionReason])] + | TopLevelInstallConstraintUnsatisfiable + PackageName + +showLog :: Log -> String +showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of + ("", y) -> y + (x, "") -> x + (x, y) -> x ++ " and " ++ y + + where + selectedMsg = "selecting " ++ case selected of + [] -> "" + [s] -> display (packageId s) ++ " " ++ kind s + (s:ss) -> listOf id + $ (display (packageId s) ++ " " ++ kind s) + : [ display (packageVersion s') ++ " " ++ kind s' + | s' <- ss ] + + kind (InstalledOnly _) = "(installed)" + kind (AvailableOnly _) = "(hackage)" + kind (InstalledAndAvailable _ _) = "(installed or hackage)" + + discardedMsg = case discarded of + [] -> "" + _ -> "discarding " ++ listOf id + [ element + | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) + , element <- display pkgid : map (display . packageVersion) pkgids ] + +showFailure :: Failure -> String +showFailure (ConfigureFailed pkg missingDeps) = + "cannot configure " ++ displayPkg pkg ++ ". It requires " + ++ listOf (displayDep . fst) missingDeps + ++ '\n' : unlines (map (uncurry whyNot) missingDeps) + + where + whyNot (Dependency name ver) [] = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + + whyNot dep conflicts = + "For the dependency on " ++ displayDep 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 " ++ displayDep dep ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintConflict name ver conflicts) = + "constraints conflict: " + ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + +showFailure (TopLevelInstallConstraintConflict name conflicts) = + "constraints conflict: " + ++ "top level constraint " ++ display name ++ "-installed however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelInstallConstraintUnsatisfiable name) = + "There is no installed version of " ++ display name + +displayVer :: VersionRange -> String +displayVer = display . simplifyVersionRange + +displayDep :: Dependency -> String +displayDep = display . simplifyDependency + +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- ------------------------------------------------------------ +-- * 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/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -0,0 +1,316 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + isPaired, + + constrain, + Satisfiable(..), + conflicting, + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName, PackageIdentifier(..) + , Package(packageId), packageName, packageVersion + , PackageFixedDeps(depends) + , Dependency(Dependency) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) + +import Data.List + ( foldl' ) +import Data.Monoid + ( Monoid(mempty) ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Data.Map (Map) +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)) + + -- Paired choices + (Map PackageName (Version, Version)) + + -- Choices that we have excluded for some reason + -- usually by applying constraints + (PackageIndex (ExcludedPackage PackageIdentifier reason)) + + -- Purely for the invariant, we keep a copy of the original index + (PackageIndex (InstalledOrAvailable installed available)) + + +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 + +-- | There is a conservation of packages property. Packages are never gained or +-- lost, they just transfer from the remaining pot to the excluded pot. +-- +invariant :: (Package installed, Package available) + => Constraints installed available a -> Bool +invariant (Constraints available _ excluded original) = all check merged + where + merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) + (PackageIndex.allPackages original) + (mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages excluded)) + where + mergedPackageId (OnlyInLeft p ) = packageId p + mergedPackageId (OnlyInRight p) = packageId p + mergedPackageId (InBoth p _) = packageId p + + check (InBoth (InstalledOnly _) cur) = case cur of + -- If the package was originally installed only then + -- now it's either still remaining as installed only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only installed + OnlyInLeft (InstalledOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> False + + check (InBoth (AvailableOnly _) cur) = case cur of + -- If the package was originally available only then + -- now it's either still remaining as available only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only available + OnlyInLeft (AvailableOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> True + + -- If the package was originally installed and available + -- then there are three cases. + check (InBoth (InstalledAndAvailable _ _) cur) = case cur of + -- We can have both remaining: + OnlyInLeft (InstalledAndAvailable _ _) -> True + -- both excluded, in particular it can have had the available excluded + -- and later had both excluded so we do not mind if the available excluded + -- is empty or non-empty. + OnlyInRight (ExcludedPackage _ _ (_:_)) -> True + -- the installed remaining and the available excluded: + InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True + _ -> False + + check _ = 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 ] + ++ [ pkg | InBoth (ExcludedPackage _ (_:_) []) + pkg@(ExcludedPackage _ (_:_) (_:_)) + <- excludedChange ] + availableChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages available') + excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages excluded) + (PackageIndex.allPackages excluded') + +-- | We construct 'Constraints' with an initial 'PackageIndex' of all the +-- packages available. +-- +empty :: (PackageFixedDeps installed, Package available) + => PackageIndex installed + -> PackageIndex available + -> Constraints installed available reason +empty installed available = Constraints pkgs pairs mempty pkgs + where + pkgs = PackageIndex.fromList + . map toInstalledOrAvailable + $ mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages installed) + (PackageIndex.allPackages available) + toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i + toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a + toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + + -- pick up cases like base-3 and 4 where one version depends on the other: + pairs = Map.fromList + [ (name, (packageVersion pkgid1, packageVersion pkgid2)) + | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed + , let name = packageName pkg1 + pkgid1 = packageId pkg1 + pkgid2 = packageId pkg2 + , any ((pkgid1==) . packageId) (depends pkg2) + || any ((pkgid2==) . packageId) (depends pkg1) ] + +-- | The package choices that are still available. +-- +choices :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIndex (InstalledOrAvailable installed available) +choices (Constraints available _ _ _) = available + +isPaired :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIdentifier -> Maybe PackageIdentifier +isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) = + case Map.lookup name pairs of + Just (v1, v2) + | version == v1 -> Just (PackageIdentifier name v2) + | version == v2 -> Just (PackageIdentifier name v1) + _ -> Nothing + +data Satisfiable constraints discarded reason + = Satisfiable constraints discarded + | Unsatisfiable + | ConflictsWith [(PackageIdentifier, [reason])] + +constrain :: (Package installed, Package available) + => TaggedDependency + -> reason + -> Constraints installed available reason + -> Satisfiable (Constraints installed available reason) + [PackageIdentifier] reason +constrain (TaggedDependency installedConstraint (Dependency name versionRange)) + reason constraints@(Constraints available paired excluded original) + + | not anyRemaining + = if null conflicts then Unsatisfiable + else ConflictsWith conflicts + + | otherwise + = let constraints' = Constraints available' paired excluded' original + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' (map packageId newExcluded) + + 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 _ -> 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' = foldl' (flip PackageIndex.insert) excluded + (newExcluded ++ oldExcluded) + + newExcluded = catMaybes (map exclude availableChoices) where + exclude pkg + | not (satisfiesVersionConstraint pkg) + = Just (ExcludedPackage pkgid [] [reason]) + | installedConstraint == NoInstalledConstraint + = Nothing + | otherwise = case pkg of + InstalledOnly _ -> Nothing + AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason]) + InstalledAndAvailable _ _ -> + case PackageIndex.lookupPackageId excluded pkgid of + Just (ExcludedPackage _ avail both) + -> Just (ExcludedPackage pkgid (reason:avail) both) + Nothing -> Just (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. + oldExcluded = catMaybes (map 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) + = Just (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 + = Just (ExcludedPackage pkgid (reason:avail) both) + | otherwise = Nothing + + -- util definitions + availableChoices = PackageIndex.lookupPackageName available name + excludedChoices = PackageIndex.lookupPackageName excluded name + + satisfiesConstraint pkg = satisfiesVersionConstraint pkg + && satisfiesInstallStateConstraint pkg + + satisfiesVersionConstraint :: Package pkg => pkg -> Bool + satisfiesVersionConstraint = case Map.lookup name paired of + Nothing -> \pkg -> + packageVersion pkg `withinRange` versionRange + Just (v1, v2) -> \pkg -> case packageVersion pkg of + v | v == v1 + || v == v2 -> v1 `withinRange` versionRange + || v2 `withinRange` versionRange + | otherwise -> v `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/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..), InstalledPackage ) + +import Distribution.Package + ( PackageIdentifier, Dependency + , Package(packageId), PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( FlagAssignment ) + +-- ------------------------------------------------------------ +-- * The various kinds of packages +-- ------------------------------------------------------------ + +type SelectablePackage + = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage + +type SelectedPackage + = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage + +data InstalledOrAvailable installed available + = InstalledOnly installed + | AvailableOnly available + | InstalledAndAvailable installed available + +type TopologicalSortNumber = Int + +data InstalledPackageEx + = InstalledPackageEx + InstalledPackage + !TopologicalSortNumber + [PackageIdentifier] -- transative closure of installed deps + +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 InstalledPackageEx where + packageId (InstalledPackageEx p _ _) = packageId p + +instance PackageFixedDeps InstalledPackageEx where + depends (InstalledPackageEx _ _ deps) = deps + +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/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ( + DependencyResolver, + + PackageConstraint(..), + PackagePreferences(..), + InstalledPreference(..), + + Progress(..), + foldProgress, + ) where + +import Distribution.Client.Types + ( AvailablePackage(..), InstalledPackage ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( VersionRange ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) + +import Prelude hiding (fail) + +-- | 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 = Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress String String [InstallPlan.PlanPackage] + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +data PackageConstraint + = PackageVersionConstraint PackageName VersionRange + | PackageInstalledConstraint PackageName + | PackageFlagsConstraint PackageName FlagAssignment + +-- | A per-package preference on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- a 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also hase a 'PackageVersionPreference' which +-- is a suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences VersionRange InstalledPreference + +-- | Wether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = 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/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs @@ -0,0 +1,259 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..), AvailablePackageDb(..) + , Repo(..), RemoteRepo(..), LocalRepo(..) + , InstalledPackage ) +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.Dependency as Dependency + ( resolveDependenciesWithProgress + , resolveAvailablePackages + , dependencyConstraints, dependencyTargets + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) ) +import Distribution.Client.Dependency.Types + ( foldProgress ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI ) +import Distribution.Client.Setup + ( FetchFlags(..) ) + +import Distribution.Package + ( PackageIdentifier, packageId, packageName, packageVersion + , Dependency(..) ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( Compiler(compilerId), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.Setup + ( fromFlag ) +import Distribution.Simple.Utils + ( die, notice, info, debug, setupMessage ) +import Distribution.System + ( buildPlatform ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import qualified Data.Map as Map +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) ) + + +-- 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 + downloadURI verbosity uri path + 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 + downloadURI verbosity uri path + 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 + LocalTarballPackage _ -> return True + RemoteTarballPackage _ -> return False --TODO: ad-hoc download caching + 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 info verbosity $ display pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do setupMessage verbosity "Downloading" pkgid + downloadPackage verbosity repo pkgid + +-- |Fetch a list of packages and their dependencies. +fetch :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> FetchFlags + -> [UnresolvedDependency] + -> IO () +fetch verbosity _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +fetch verbosity packageDBs repos comp conf flags deps = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + availableDb@(AvailablePackageDb available _) + <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available deps + + pkgs <- resolvePackages verbosity + includeDeps comp + installed availableDb deps' + + pkgs' <- filterM (fmap not . isFetched) pkgs + when (null pkgs') $ + notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already cached." + if dryRun + then notice verbosity $ unlines $ + "The following packages would be fetched:" + : map (display . packageId) pkgs' + else sequence_ + [ fetchPackage verbosity repo pkgid + | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ] + where + includeDeps = fromFlag (fetchDeps flags) + dryRun = fromFlag (fetchDryRun flags) + + +resolvePackages + :: Verbosity + -> Bool + -> Compiler + -> PackageIndex InstalledPackage + -> AvailablePackageDb + -> [UnresolvedDependency] + -> IO [AvailablePackage] +resolvePackages verbosity includeDependencies comp + installed (AvailablePackageDb available availablePrefs) deps + + | includeDependencies = do + + notice verbosity "Resolving dependencies..." + plan <- foldProgress logMsg die return $ + resolveDependenciesWithProgress + buildPlatform (compilerId comp) + installed' available + preferences constraints + targets + --TODO: suggest using --no-deps, unpack or fetch -o + -- if cannot satisfy deps + --TODO: add commandline constraint and preference args for fetch + + return (selectPackagesToFetch plan) + + | otherwise = do + + either (die . unlines . map show) return $ + resolveAvailablePackages + installed available + preferences constraints + targets + + where + targets = dependencyTargets deps + constraints = dependencyConstraints deps + preferences = PackagesPreference + PreferLatestForSelected + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + + installed' = hideGivenDeps deps installed + + -- 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). + + -- TODO: to allow for preferences on selecting an available version + -- corresponding to a package we've got installed, instead of hiding the + -- installed instances, we should add a constraint on using an installed + -- instance. + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + + -- The packages we want to fetch are those packages the 'InstallPlan' that + -- are in the 'InstallPlan.Configured' state. + selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage] + selectPackagesToFetch plan = + [ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList plan ] + + logMsg message rest = info verbosity message >> rest + + +-- |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 + display (packageName pkgid) + display (packageVersion 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) + ,display (packageName pkgid) + ,display (packageVersion pkgid) + ,display pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,display pkgid <.> "tar.gz"] + } diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GZipUtils +-- Copyright : (c) Dmitry Astapov 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Provides a convenience functions for working with files that may or may not +-- be zipped. +----------------------------------------------------------------------------- +module Distribution.Client.GZipUtils ( + maybeDecompress, + ) where + +import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..)) +import Data.ByteString.Lazy (ByteString) +import Codec.Compression.GZip +import Codec.Compression.Zlib.Internal + +-- | Attempts to decompress the `bytes' under the assumption that +-- "data format" error at the very beginning of the stream means +-- that it is already decompressed. Caller should make sanity checks +-- to verify that it is not, in fact, garbage. +-- +-- This is to deal with http proxies that lie to us and transparently +-- decompress without removing the content-encoding header. See: +-- +-- +maybeDecompress :: ByteString -> ByteString +maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes + where + -- DataError at the beginning of the stream probably means that stream is not compressed. + -- Returning it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. + foldStream (StreamError DataError _) = bytes + foldStream somethingElse = doFold somethingElse + + doFold StreamEnd = BS.Empty + doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) + doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Data.Maybe (listToMaybe) +import Data.List (maximumBy) +import Control.Monad (guard) +import System.Directory (createDirectoryIfMissing, doesFileExist, + renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package (Package(..)) +import Distribution.Simple.Program (haddockProgram, ProgramConfiguration + , rawSystemProgram, requireProgramVersion) +import Distribution.Version (Version(Version), orLaterVersion) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.PackageIndex(PackageIndex, allPackages, + allPackagesByName, fromList) +import Distribution.Simple.Utils + ( comparing, intercalate, debug + , installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) +import Distribution.Client.Types + ( InstalledPackage(..) ) + +regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex verbosity pkgs conf index = do + (paths,warns) <- haddockPackagePaths pkgs' + case warns of + Nothing -> return () + Just m -> debug verbosity m + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) conf + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + + let flags = [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths ] + rawSystemProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' = map (maximumBy $ comparing packageId) + . allPackagesByName + . fromList + . filter exposed + . map (\(InstalledPackage pkg _) -> pkg) + . allPackages + $ pkgs + +haddockPackagePaths :: [InstalledPackageInfo] + -> IO ([(FilePath, FilePath)], Maybe String) +haddockPackagePaths pkgs = do + interfaces <- sequence + [ case interfaceAndHtmlPath pkg of + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (pkgid, Just (interface, html)) + else return (pkgid, Nothing) + Nothing -> return (pkgid, Nothing) + | pkg <- pkgs, let pkgid = packageId pkg ] + + let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] + + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + + flags = [ x | (_, Just x) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + guard (not . null $ html) + return (interface, html) diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs @@ -0,0 +1,197 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + downloadURI, + getHTTP, + proxy, + isOldHackageURI + ) where + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) +import Network.Stream + ( Result, ConnError(..) ) +import Network.Browser + ( Proxy (..), Authority (..), browse + , setOutHandler, setErrHandler, setProxy, request) +import Control.Monad + ( mplus, join, liftM2 ) +import qualified Data.ByteString.Lazy.Char8 as ByteString +import Data.ByteString.Lazy (ByteString) +#ifdef WIN32 +import System.Win32.Types + ( DWORD, HKEY ) +import System.Win32.Registry + ( hKEY_CURRENT_USER, regOpenKey, regCloseKey + , regQueryValue, regQueryValueEx ) +import Control.Exception + ( bracket ) +import Distribution.Compat.Exception + ( handleIO ) +import Foreign + ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif +import System.Environment (getEnvironment) + +import qualified Paths_cabal_install (version) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils + ( die, info, warn, debug + , copyFileVerbose, writeFileAtomic ) +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, envProxyString, registryProxyString :: IO (Maybe String) +#ifdef WIN32 +-- read proxy settings from the windows registry +registryProxyString = handleIO (\_ -> 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 +registryProxyString = return Nothing +#endif + +-- read proxy settings by looking for an env var +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +proxyString = liftM2 mplus envProxyString registryProxyString + + +-- |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 +--TODO: print info message when we're using a proxy + +-- | 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 (fixUserInfo uri) + _ -> Nothing + +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + where + f a@URIAuth{ uriUserInfo = s } = + a{ uriUserInfo = case reverse s of + '@':s' -> reverse s' + _ -> s + } +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 ByteString +mkRequest uri = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = ByteString.empty } + 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 ByteString)) +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) + +downloadURI :: Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO () +downloadURI verbosity uri path | uriScheme uri == "file:" = + copyFileVerbose verbosity (uriPath uri) path +downloadURI verbosity uri path = do + result <- getHTTP verbosity uri + let result' = case result of + Left err -> Left err + Right rsp -> case rspCode rsp of + (2,0,0) -> Right (rspBody rsp) + (a,b,c) -> Left err + where + err = ErrorMisc $ "Unsucessful HTTP code: " + ++ concatMap show [a,b,c] + + case result' of + Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err + Right body -> do + info verbosity ("Downloaded to " ++ path) + writeFileAtomic path (ByteString.unpack body) + --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. + +-- 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/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs @@ -0,0 +1,299 @@ +----------------------------------------------------------------------------- +-- | +-- 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 ( + getInstalledPackages, + getAvailablePackages, + + readPackageIndexFile, + parseRepoIndex, + + disambiguatePackageName, + disambiguateDependencies + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) + , AvailablePackageDb(..), InstalledPackage(..) ) + +import Distribution.Package + ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) + , Dependency(Dependency), InstalledPackageId(..) ) +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse + ( parsePackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Version + ( Version(Version), intersectVersionRanges ) +import Distribution.Text + ( display, simpleParse ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) + +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (isPrefixOf) +import Data.Monoid (Monoid(..)) +import qualified Data.Map as Map +import Control.Monad (MonadPlus(mplus), when) +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 Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.FilePath.Posix as FilePath.Posix + ( takeFileName ) +import System.IO.Error (isDoesNotExistError) +import System.Directory + ( getModificationTime ) +import System.Time + ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO (PackageIndex InstalledPackage) +getInstalledPackages verbosity comp packageDbs conf = + fmap convert (Configure.getInstalledPackages verbosity comp packageDbs conf) + where + convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage + convert index = PackageIndex.fromList $ + reverse -- because later ones mask earlier ones, but + -- InstalledPackageIndex.allPackages gives us the most preferred + -- instances first, when packages share a package id, like when + -- the same package is installed in the global & user dbs. + [ InstalledPackage ipkg (sourceDeps index ipkg) + | ipkg <- InstalledPackageIndex.allPackages index ] + + -- The InstalledPackageInfo only lists dependencies by the + -- InstalledPackageId, which means we do not directly know the corresponding + -- source dependency. The only way to find out is to lookup the + -- InstalledPackageId to get the InstalledPackageInfo and look at its + -- source PackageId. But if the package is broken because it depends on + -- other packages that do not exist then we have a problem we cannot find + -- the original source package id. Instead we make up a bogus package id. + -- This should have the same effect since it should be a dependency on a + -- non-existant package. + sourceDeps index ipkg = + [ maybe (brokenPackageId depid) packageId mdep + | let depids = InstalledPackageInfo.depends ipkg + getpkg = InstalledPackageIndex.lookupInstalledPackageId index + , (depid, mdep) <- zip depids (map getpkg depids) ] + + brokenPackageId (InstalledPackageId str) = + PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'AvailablePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb +getAvailablePackages verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." + return AvailablePackageDb { + packageIndex = mempty, + packagePreferences = mempty + } +getAvailablePackages verbosity repos = do + info verbosity "Reading available packages..." + pkgss <- mapM (readRepoIndex verbosity) repos + let (pkgs, prefs) = mconcat pkgss + prefs' = Map.fromListWith intersectVersionRanges + [ (name, range) | Dependency name range <- prefs ] + _ <- evaluate pkgs + _ <- evaluate prefs' + return AvailablePackageDb { + packageIndex = pkgs, + packagePreferences = prefs' + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'AvailablePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> Repo + -> IO (PackageIndex AvailablePackage, [Dependency]) +readRepoIndex verbosity repo = handleNotFound $ do + let indexFile = repoLocalDir repo "00-index.tar" + (pkgs, prefs) <- either fail return + . foldlTarball extract ([], []) + =<< BS.readFile indexFile + + pkgIndex <- evaluate $ PackageIndex.fromList + [ AvailablePackage { + packageInfoId = pkgid, + packageDescription = pkg, + packageSource = RepoTarballPackage repo + } + | (pkgid, pkg) <- pkgs] + + warnIfIndexIsOld indexFile + return (pkgIndex, prefs) + + where + extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ + (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) + `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) + + extractPrefs :: Tar.Entry -> Maybe [Dependency] + extractPrefs entry = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeFileName (Tar.entryPath entry) == "preferred-versions" + -> Just . parsePreferredVersions + . BS.Char8.unpack $ content + _ -> Nothing + + 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 'hackport 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 + + isOldThreshold = 15 --days + warnIfIndexIsOld indexFile = do + indexTime <- getModificationTime indexFile + currentTime <- getClockTime + let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) + when (tdDay diff >= isOldThreshold) $ case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " + ++ "'hackport update' to get the latest list of available packages." + Right _localRepo -> return () + +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. +-- +-- This is supposed to be an \"all in one\" way to easily get at the info in +-- the hackage package index. +-- +-- It takes a function to map a 'GenericPackageDescription' into any more +-- specific instance of 'Package' that you might want to use. In the simple +-- case you can just use @\_ p -> p@ here. +-- +readPackageIndexFile :: Package pkg + => (PackageId -> GenericPackageDescription -> pkg) + -> FilePath -> IO (PackageIndex pkg) +readPackageIndexFile mkPkg indexFile = do + pkgs <- either fail return + . parseRepoIndex + . maybeDecompress + =<< BS.readFile indexFile + + evaluate $ PackageIndex.fromList + [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- +parseRepoIndex :: ByteString + -> Either String [(PackageId, GenericPackageDescription)] +parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] + +extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) +extractPkg entry = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeExtension fileName == ".cabal" + -> case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParse vers of + Just ver -> Just (pkgid, descr) + where + pkgid = PackageIdentifier (PackageName pkgname) ver + parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack + $ content + descr = case parsed of + ParseOk _ d -> d + _ -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + _ -> Nothing + where + fileName = Tar.entryPath entry + +foldlTarball :: (a -> Tar.Entry -> a) -> a + -> ByteString -> Either String a +foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read + where + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es + +-- | 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 " ++ display name ++ ". " + ++ "Perhaps you need to run 'hackport update' first?" + else "The package name " ++ display name ++ "is ambigious. " + ++ "It could be: " ++ intercalate ", " (map display 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 + -> PackageName + -> Either PackageName [PackageName] +disambiguatePackageName index (PackageName 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/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init ( + + -- * Commands + initCabal + + ) where + +import System.IO + ( hSetBuffering, stdout, BufferMode(..) ) +import System.Directory + ( getCurrentDirectory ) +import Data.Time + ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) + +import Data.List + ( intersperse ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Traversable + ( traverse ) +import Control.Monad + ( when ) +#if MIN_VERSION_base(3,0,0) +import Control.Monad + ( (>=>) ) +#endif + +import Text.PrettyPrint.HughesPJ hiding (mode, cat) + +import Data.Version + ( Version(..) ) +import Distribution.Version + ( orLaterVersion ) + +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..), Category(..) ) +import Distribution.Client.Init.Licenses + ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) +import Distribution.Client.Init.Heuristics + ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) + +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.ModuleName + ( ) -- for the Text instance + +import Distribution.ReadE + ( runReadE, readP_to_E ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Text + ( display, Text(..) ) + +initCabal :: InitFlags -> IO () +initCabal initFlags = do + hSetBuffering stdout NoBuffering + + initFlags' <- extendFlags initFlags + + writeLicense initFlags' + writeSetupFile initFlags' + success <- writeCabalFile initFlags' + + when success $ generateWarnings initFlags' + +--------------------------------------------------------------------------- +-- Flag acquisition ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- | Fill in more details by guessing, discovering, or prompting the +-- user. +extendFlags :: InitFlags -> IO InitFlags +extendFlags = getPackageName + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getLibOrExec + >=> getSrcDir + >=> getModulesAndBuildTools + +-- | Combine two actions which may return a value, preferring the first. That +-- is, run the second action only if the first doesn't return a value. +infixr 1 ?>> +(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +f ?>> g = do + ma <- f + if isJust ma + then return ma + else g + +-- | Witness the isomorphism between Maybe and Flag. +maybeToFlag :: Maybe a -> Flag a +maybeToFlag = maybe NoFlag Flag + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. +getPackageName :: InitFlags -> IO InitFlags +getPackageName flags = do + guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) + ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) + + pkgName' <- return (flagToMaybe $ packageName flags) + ?>> maybePrompt flags (promptStr "Package name" guess) + ?>> return guess + + return $ flags { packageName = maybeToFlag pkgName' } + +-- | Package version: use 0.1 as a last resort, but try prompting the user if +-- possible. +getVersion :: InitFlags -> IO InitFlags +getVersion flags = do + let v = Just $ Version { versionBranch = [0,1], versionTags = [] } + v' <- return (flagToMaybe $ version flags) + ?>> maybePrompt flags (prompt "Package version" v) + ?>> return v + return $ flags { version = maybeToFlag v' } + +-- | Choose a license. +getLicense :: InitFlags -> IO InitFlags +getLicense flags = do + lic <- return (flagToMaybe $ license flags) + ?>> fmap (fmap (either UnknownLicense id)) + (maybePrompt flags + (promptList "Please choose a license" + knownLicenses (Just BSD3) True)) + return $ flags { license = maybeToFlag lic } + +-- | The author's name and email. Prompt, or try to guess from an existing +-- darcs repo. +getAuthorInfo :: InitFlags -> IO InitFlags +getAuthorInfo flags = do + (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail + authorName' <- return (flagToMaybe $ author flags) + ?>> maybePrompt flags (promptStr "Author name" authorName) + ?>> return authorName + + authorEmail' <- return (flagToMaybe $ email flags) + ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) + ?>> return authorEmail + + return $ flags { author = maybeToFlag authorName' + , email = maybeToFlag authorEmail' + } + +-- | Prompt for a homepage URL. +getHomepage :: InitFlags -> IO InitFlags +getHomepage flags = do + hp <- queryHomepage + hp' <- return (flagToMaybe $ homepage flags) + ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) + ?>> return hp + + return $ flags { homepage = maybeToFlag hp' } + +-- | Right now this does nothing, but it could be changed to do some +-- intelligent guessing. +queryHomepage :: IO (Maybe String) +queryHomepage = return Nothing -- get default remote darcs repo? + +-- | Prompt for a project synopsis. +getSynopsis :: InitFlags -> IO InitFlags +getSynopsis flags = do + syn <- return (flagToMaybe $ synopsis flags) + ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) + + return $ flags { synopsis = maybeToFlag syn } + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: InitFlags -> IO InitFlags +getCategory flags = do + cat <- return (flagToMaybe $ category flags) + ?>> maybePrompt flags (promptList "Project category" [Codec ..] + Nothing True) + return $ flags { category = maybeToFlag cat } + +-- | Ask whether the project builds a library or executable. +getLibOrExec :: InitFlags -> IO InitFlags +getLibOrExec flags = do + isLib <- return (flagToMaybe $ packageType flags) + ?>> maybePrompt flags (either (const Library) id `fmap` + (promptList "What does the package build" + [Library, Executable] + Nothing False)) + ?>> return (Just Library) + + return $ flags { packageType = maybeToFlag isLib } + +-- | Try to guess the source root directory (don't prompt the user). +getSrcDir :: InitFlags -> IO InitFlags +getSrcDir flags = do + srcDirs <- return (sourceDirs flags) + ?>> guessSourceDirs + + return $ flags { sourceDirs = srcDirs } + +-- XXX +-- | Try to guess source directories. +guessSourceDirs :: IO (Maybe [String]) +guessSourceDirs = return Nothing + +-- | Get the list of exposed modules and extra tools needed to build them. +getModulesAndBuildTools :: InitFlags -> IO InitFlags +getModulesAndBuildTools flags = do + dir <- fromMaybe getCurrentDirectory + (fmap return . flagToMaybe $ packageDir flags) + + -- XXX really should use guessed source roots. + sourceFiles <- scanForModules dir + + mods <- return (exposedModules flags) + ?>> (return . Just . map moduleName $ sourceFiles) + + tools <- return (buildTools flags) + ?>> (return . Just . neededBuildPrograms $ sourceFiles) + + return $ flags { exposedModules = mods + , buildTools = tools } + +--------------------------------------------------------------------------- +-- Prompting/user interaction ------------------------------------------- +--------------------------------------------------------------------------- + +-- | Run a prompt or not based on the nonInteractive flag of the +-- InitFlags structure. +maybePrompt :: InitFlags -> IO t -> IO (Maybe t) +maybePrompt flags p = + case nonInteractive flags of + Flag True -> return Nothing + _ -> Just `fmap` p + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: String -> Maybe String -> IO String +promptStr = promptDefault' Just id + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: Text t => String -> Maybe t -> IO t +prompt = promptDefault' + (either (const Nothing) Just . runReadE (readP_to_E id parse)) + display + +-- | Create a prompt with an optional default value. +promptDefault' :: (String -> Maybe t) -- ^ parser + -> (t -> String) -- ^ pretty-printer + -> String -- ^ prompt message + -> Maybe t -- ^ optional default value + -> IO t +promptDefault' parser pretty pr def = do + putStr $ mkDefPrompt pr (pretty `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return d + _ -> case parser inp of + Just t -> return t + Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" + promptDefault' parser pretty pr def + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> Maybe String -> String +mkDefPrompt pr def = pr ++ defStr def ++ "? " + where defStr Nothing = "" + defStr (Just s) = " [default \"" ++ s ++ "\"]" + +-- | Create a prompt from a list of items. +promptList :: (Text t, Eq t) + => String -- ^ prompt + -> [t] -- ^ choices + -> Maybe t -- ^ optional default value + -> Bool -- ^ whether to allow an 'other' option + -> IO (Either String t) +promptList pr choices def other = do + putStrLn $ pr ++ ":" + let options1 = map (\c -> (Just c == def, display c)) choices + options2 = zip ([1..]::[Int]) + (options1 ++ if other then [(False, "Other (specify)")] + else []) + mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 + promptList' (length options2) choices def other + where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest + | otherwise = " " ++ star i ++ rest + where rest = show n ++ ") " + star True = "*" + star False = " " + +promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t) +promptList' numChoices choices def other = do + putStr $ mkDefPrompt "Your choice" (display `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return $ Right d + _ -> case readMaybe inp of + Nothing -> invalidChoice inp + Just n -> getChoice n + where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." + promptList' numChoices choices def other + getChoice n | n < 1 || n > numChoices = invalidChoice (show n) + | n < numChoices || + (n == numChoices && not other) + = return . Right $ choices !! (n-1) + | otherwise = Left `fmap` promptStr "Please specify" Nothing + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(a,"")] -> Just a + _ -> Nothing + +--------------------------------------------------------------------------- +-- File generation ------------------------------------------------------ +--------------------------------------------------------------------------- + +writeLicense :: InitFlags -> IO () +writeLicense flags = do + message flags "Generating LICENSE..." + year <- getYear + let licenseFile = + case license flags of + Flag BSD3 -> Just $ bsd3 (fromMaybe "???" + . flagToMaybe + . author + $ flags) + (show year) + + Flag (GPL (Just (Version {versionBranch = [2]}))) + -> Just gplv2 + + Flag (GPL (Just (Version {versionBranch = [3]}))) + -> Just gplv3 + + Flag (LGPL (Just (Version {versionBranch = [2]}))) + -> Just lgpl2 + + Flag (LGPL (Just (Version {versionBranch = [3]}))) + -> Just lgpl3 + + _ -> Nothing + + case licenseFile of + Just licenseText -> writeFile "LICENSE" licenseText + Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." + +getYear :: IO Integer +getYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +writeSetupFile :: InitFlags -> IO () +writeSetupFile flags = do + message flags "Generating Setup.hs..." + writeFile "Setup.hs" setupFile + where + setupFile = unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + +writeCabalFile :: InitFlags -> IO Bool +writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do + message flags "Error: no package name provided." + return False +writeCabalFile flags@(InitFlags{packageName = Flag p}) = do + let cabalFileName = p ++ ".cabal" + message flags $ "Generating " ++ cabalFileName ++ "..." + writeFile cabalFileName (generateCabalFile cabalFileName flags) + return True + +-- | Generate a .cabal file from an InitFlags structure. NOTE: this +-- is rather ad-hoc! What we would REALLY like is to have a +-- standard low-level AST type representing .cabal files, which +-- preserves things like comments, and to write an *inverse* +-- parser/pretty-printer pair between .cabal files and this AST. +-- Then instead of this ad-hoc code we could just map an InitFlags +-- structure onto a low-level AST structure and use the existing +-- pretty-printing code to generate the file. +generateCabalFile :: String -> InitFlags -> String +generateCabalFile fileName c = render $ + (if (minimal c /= Flag True) + then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.") + else empty) + $$ + vcat [ fieldS "Name" (packageName c) + (Just "The name of the package.") + True + + , field "Version" (version c) + (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") + True + + , fieldS "Synopsis" (synopsis c) + (Just "A short (one-line) description of the package.") + True + + , fieldS "Description" NoFlag + (Just "A longer description of the package.") + True + + , fieldS "Homepage" (homepage c) + (Just "URL for the project homepage or repository.") + False + + , fieldS "Bug-reports" NoFlag + (Just "A URL where users can report bugs.") + False + + , field "License" (license c) + (Just "The license under which the package is released.") + True + + , fieldS "License-file" (Flag "LICENSE") + (Just "The file containing the license text.") + True + + , fieldS "Author" (author c) + (Just "The package author(s).") + True + + , fieldS "Maintainer" (email c) + (Just "An email address to which users can send suggestions, bug reports, and patches.") + True + + , fieldS "Copyright" NoFlag + (Just "A copyright notice.") + True + + , fieldS "Category" (either id display `fmap` category c) + Nothing + True + + , fieldS "Build-type" (Flag "Simple") + Nothing + True + + , fieldS "Extra-source-files" NoFlag + (Just "Extra files to be distributed with the package, such as examples or a README.") + True + + , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] [])) + (Just "Constraint on the version of Cabal needed to build this package.") + False + + , case packageType c of + Flag Executable -> + text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat + [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo c + ]) + Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat + [ fieldS "Exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo c + ]) + _ -> empty + ] + where + generateBuildInfo :: InitFlags -> Doc + generateBuildInfo c' = vcat + [ fieldS "Build-depends" (listField (dependencies c')) + (Just "Packages needed in order to build this package.") + True + + , fieldS "Other-modules" (listField (otherModules c')) + (Just "Modules not exported by this package.") + True + + , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) + (Just "Directories other than the root containing source files.") + False + + , fieldS "Build-tools" (listFieldS (buildTools c')) + (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") + True + ] + + listField :: Text s => Maybe [s] -> Flag String + listField = listFieldS . fmap (map display) + + listFieldS :: Maybe [String] -> Flag String + listFieldS = Flag . maybe "" (concat . intersperse ", ") + + field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc + field s f = fieldS s (fmap display f) + + fieldS :: String -- ^ Name of the field + -> Flag String -- ^ Field contents + -> Maybe String -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Doc + fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty + fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty + fieldS s f com _ = case (isJust com, noComments c, minimal c) of + (_, _, Flag True) -> id + (_, Flag True, _) -> id + (True, _, _) -> (showComment com $$) . ($$ text "") + (False, _, _) -> ($$ text "") + $ + comment f <> text s <> colon + <> text (take (20 - length s) (repeat ' ')) + <> text (fromMaybe "" . flagToMaybe $ f) + comment NoFlag = text "-- " + comment (Flag "") = text "-- " + comment _ = text "" + + showComment :: Maybe String -> Doc + showComment (Just t) = vcat . map text + . map ("-- "++) . lines + . render . fsep . map text . words $ t + showComment Nothing = text "" + +-- | Generate warnings for missing fields etc. +generateWarnings :: InitFlags -> IO () +generateWarnings flags = do + message flags "" + when (synopsis flags `elem` [NoFlag, Flag ""]) + (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") + + message flags "You may want to edit the .cabal file and add a Description field." + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: InitFlags -> String -> IO () +message (InitFlags{quiet = Flag True}) _ = return () +message _ s = putStrLn s + +#if MIN_VERSION_base(3,0,0) +#else +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g +#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Heuristics ( + guessPackageName, + scanForModules, SourceFileEntry(..), + neededBuildPrograms, + guessAuthorNameMail, + knownCategories, +) where +import Distribution.Simple.Setup(Flag(..)) +import Distribution.ModuleName ( ModuleName, fromString ) +import Distribution.Client.PackageIndex + ( allPackagesByName ) +import qualified Distribution.PackageDescription as PD + ( category, packageDescription ) +import Distribution.Simple.Utils + ( intercalate ) + +import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) ) +import Control.Monad (liftM ) +import Data.Char ( isUpper, isLower, isSpace ) +#if MIN_VERSION_base(3,0,3) +import Data.Either ( partitionEithers ) +#endif +import Data.Maybe ( catMaybes ) +import Data.Monoid ( mempty, mappend ) +import qualified Data.Set as Set ( fromList, toList ) +import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, + getHomeDirectory, canonicalizePath ) +import System.Environment ( getEnvironment ) +import System.FilePath ( takeExtension, takeBaseName, dropExtension, + (), splitDirectories, makeRelative ) + +-- |Guess the package name based on the given root directory +guessPackageName :: FilePath -> IO String +guessPackageName = liftM (last . splitDirectories) . canonicalizePath + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + } deriving Show + +-- |Search for source files in the given directory +-- and return pairs of guessed haskell source path and +-- module names. +scanForModules :: FilePath -> IO [SourceFileEntry] +scanForModules rootDir = scanForModulesIn rootDir rootDir + +scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] +scanForModulesIn projectRoot srcRoot = scan srcRoot [] + where + scan dir hierarchy = do + entries <- getDirectoryContents (projectRoot dir) + (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) + let modules = catMaybes [ guessModuleName hierarchy file + | file <- files + , isUpper (head file) ] + recMods <- mapM (scanRecursive dir hierarchy) dirs + return $ concat (modules : recMods) + tagIsDir parent entry = do + isDir <- doesDirectoryExist (parent entry) + return $ (if isDir then Right else Left) entry + guessModuleName hierarchy entry + | takeBaseName entry == "Setup" = Nothing + | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext + | otherwise = Nothing + where + relRoot = makeRelative projectRoot srcRoot + unqualModName = dropExtension entry + modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) + ext = case takeExtension entry of '.':e -> e; e -> e + scanRecursive parent hierarchy entry + | isUpper (head entry) = scan (parent entry) (entry : hierarchy) + | isLower (head entry) && not (ignoreDir entry) = + scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) + | otherwise = return [] + ignoreDir ('.':_) = True + ignoreDir dir = dir `elem` ["dist", "_darcs"] + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: [(String,String)] +knownSuffixHandlers = + [ ("gc", "greencard") + , ("chs", "chs") + , ("hsc", "hsc2hs") + , ("x", "alex") + , ("y", "happy") + , ("ly", "happy") + , ("cpphs", "cpp") + ] + +sourceExtensions :: [String] +sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers + +neededBuildPrograms :: [SourceFileEntry] -> [String] +neededBuildPrograms entries = + [ handler + | ext <- nubSet (map fileExtension entries) + , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) + ] + +-- |Guess author and email +guessAuthorNameMail :: IO (Flag String, Flag String) +guessAuthorNameMail = + update (readFromFile authorRepoFile) mempty >>= + update (getAuthorHome >>= readFromFile) >>= + update readFromEnvironment + where + update _ info@(Flag _, Flag _) = return info + update extract info = liftM (`mappend` info) extract -- prefer info + readFromFile file = do + exists <- doesFileExist file + if exists then liftM nameAndMail (readFile file) else return mempty + readFromEnvironment = fmap extractFromEnvironment getEnvironment + extractFromEnvironment env = + let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) + emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) + in darcsEmailEnv `mappend` emailEnv + getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory + authorRepoFile = "_darcs" "prefs" "author" + +-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached +knownCategories :: AvailablePackageDb -> [String] +knownCategories (AvailablePackageDb available _) = nubSet $ + [ cat | pkg <- map head (allPackagesByName available) + , let catList = (PD.category . PD.packageDescription . packageDescription) pkg + , cat <- splitString ',' catList + ] + +-- Parse name and email, from darcs pref files or environment variable +nameAndMail :: String -> (Flag String, Flag String) +nameAndMail str + | all isSpace nameOrEmail = mempty + | null erest = (mempty, Flag $ trim nameOrEmail) + | otherwise = (Flag $ trim nameOrEmail, Flag email) + where + (nameOrEmail,erest) = break (== '<') str + (email,_) = break (== '>') (tail erest) + trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + removeLeadingSpace = dropWhile isSpace + +-- split string at given character, and remove whitespaces +splitString :: Char -> String -> [String] +splitString sep str = go str where + go s = if null s' then [] else tok : go rest where + s' = dropWhile (\c -> c == sep || isSpace c) s + (tok,rest) = break (==sep) s' + +nubSet :: (Ord a) => [a] -> [a] +nubSet = Set.toList . Set.fromList + +{- +test db testProjectRoot = do + putStrLn "Guessed package name" + (guessPackageName >=> print) testProjectRoot + putStrLn "Guessed name and email" + guessAuthorNameMail >>= print + + mods <- scanForModules testProjectRoot + + putStrLn "Guessed modules" + mapM_ print mods + putStrLn "Needed build programs" + print (neededBuildPrograms mods) + + putStrLn "List of known categories" + print $ knownCategories db +-} + +#if MIN_VERSION_base(3,0,3) +#else +partitionEithers :: [Either a b] -> ([a],[b]) +partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) +#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,1722 @@ +module Distribution.Client.Init.Licenses + ( License + , bsd3 + , gplv2 + , gplv3 + , lgpl2 + , lgpl3 + + ) where + +type License = String + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c)" ++ year ++ ", " ++ authors + , "" + , "All rights reserved." + , "" + , "Redistribution and use in source and binary forms, with or without" + , "modification, are permitted provided that the following conditions are met:" + , "" + , " * Redistributions of source code must retain the above copyright" + , " notice, this list of conditions and the following disclaimer." + , "" + , " * Redistributions in binary form must reproduce the above" + , " copyright notice, this list of conditions and the following" + , " disclaimer in the documentation and/or other materials provided" + , " with the distribution." + , "" + , " * Neither the name of " ++ authors ++ " nor the names of other" + , " contributors may be used to endorse or promote products derived" + , " from this software without specific prior written permission." + , "" + , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS" + , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT" + , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR" + , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT" + , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," + , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT" + , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE," + , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY" + , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT" + , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE" + , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , " " + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , " " + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + , "" + ] + +lgpl2 :: License +lgpl2 = unlines + [ " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1991 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the library GPL. It is" + , " numbered 2 because it goes with version 2 of the ordinary GPL.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Library General Public License, applies to some" + , "specially designated Free Software Foundation software, and to any" + , "other libraries whose authors decide to use it. You can use it for" + , "your libraries, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if" + , "you distribute copies of the library, or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link a program with the library, you must provide" + , "complete object files to the recipients so that they can relink them" + , "with the library, after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " Our method of protecting your rights has two steps: (1) copyright" + , "the library, and (2) offer you this license which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " Also, for each distributor's protection, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "library. If the library is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original" + , "version, so that any problems introduced by others will not reflect on" + , "the original authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that companies distributing free" + , "software will individually obtain patent licenses, thus in effect" + , "transforming the program into proprietary software. To prevent this," + , "we have made it clear that any patent must be licensed for everyone's" + , "free use or not licensed at all." + , "" + , " Most GNU software, including some libraries, is covered by the ordinary" + , "GNU General Public License, which was designed for utility programs. This" + , "license, the GNU Library General Public License, applies to certain" + , "designated libraries. This license is quite different from the ordinary" + , "one; be sure to read it in full, and don't assume that anything in it is" + , "the same as in the ordinary license." + , "" + , " The reason we have a separate public license for some libraries is that" + , "they blur the distinction we usually make between modifying or adding to a" + , "program and simply using it. Linking a program with a library, without" + , "changing the library, is in some sense simply using the library, and is" + , "analogous to running a utility program or application program. However, in" + , "a textual and legal sense, the linked executable is a combined work, a" + , "derivative of the original library, and the ordinary General Public License" + , "treats it as such." + , "" + , " Because of this blurred distinction, using the ordinary General" + , "Public License for libraries did not effectively promote software" + , "sharing, because most developers did not use the libraries. We" + , "concluded that weaker conditions might promote sharing better." + , "" + , " However, unrestricted linking of non-free programs would deprive the" + , "users of those programs of all benefit from the free status of the" + , "libraries themselves. This Library General Public License is intended to" + , "permit developers of non-free programs to use free libraries, while" + , "preserving your freedom as a user of such programs to change the free" + , "libraries that are incorporated in them. (We have not seen how to achieve" + , "this as regards changes in header files, but we have achieved it as regards" + , "changes in the actual functions of the Library.) The hope is that this" + , "will lead to faster development of free libraries." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, while the latter only" + , "works together with the library." + , "" + , " Note that it is possible for a library to be covered by the ordinary" + , "General Public License rather than by this special one." + , "" + , " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library which" + , "contains a notice placed by the copyright holder or other authorized" + , "party saying it may be distributed under the terms of this Library" + , "General Public License (also called \"this License\"). Each licensee is" + , "addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , " " + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also compile or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " c) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " d) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the source code distributed need not include anything that is normally" + , "distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Library General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Library General Public" + , " License as published by the Free Software Foundation; either" + , " version 2 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Library General Public License for more details." + , "" + , " You should have received a copy of the GNU Library General Public" + , " License along with this library; if not, write to the Free" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions. " + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version. " + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Types where + +import Distribution.Simple.Setup + ( Flag(..) ) + +import Distribution.Version +import qualified Distribution.Package as P +import Distribution.License +import Distribution.ModuleName + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Text + +import Data.Monoid + +-- | InitFlags is really just a simple type to represent certain +-- portions of a .cabal file. Rather than have a flag for EVERY +-- possible field, we just have one for each field that the user is +-- likely to want and/or that we are likely to be able to +-- intelligently guess. +data InitFlags = + InitFlags { nonInteractive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + + , packageName :: Flag String + , version :: Flag Version + , cabalVersion :: Flag VersionRange + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + + , synopsis :: Flag String + , category :: Flag (Either String Category) + + , packageType :: Flag PackageType + + , exposedModules :: Maybe [ModuleName] + , otherModules :: Maybe [ModuleName] + + , dependencies :: Maybe [P.Dependency] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + } + deriving (Show) + +data PackageType = Library | Executable + deriving (Show, Read, Eq) + +instance Text PackageType where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] + +instance Monoid InitFlags where + mempty = InitFlags + { nonInteractive = mempty + , quiet = mempty + , packageDir = mempty + , noComments = mempty + , minimal = mempty + , packageName = mempty + , version = mempty + , cabalVersion = mempty + , license = mempty + , author = mempty + , email = mempty + , homepage = mempty + , synopsis = mempty + , category = mempty + , packageType = mempty + , exposedModules = mempty + , otherModules = mempty + , dependencies = mempty + , sourceDirs = mempty + , buildTools = mempty + } + mappend a b = InitFlags + { nonInteractive = combine nonInteractive + , quiet = combine quiet + , packageDir = combine packageDir + , noComments = combine noComments + , minimal = combine minimal + , packageName = combine packageName + , version = combine version + , cabalVersion = combine cabalVersion + , license = combine license + , author = combine author + , email = combine email + , homepage = combine homepage + , synopsis = combine synopsis + , category = combine category + , packageType = combine packageType + , exposedModules = combine exposedModules + , otherModules = combine otherModules + , dependencies = combine dependencies + , sourceDirs = combine sourceDirs + , buildTools = combine buildTools + } + where combine field = field a `mappend` field b + +-- | Some common package categories. +data Category + = Codec + | Concurrency + | Control + | Data + | Database + | Development + | Distribution + | Game + | Graphics + | Language + | Math + | Network + | Sound + | System + | Testing + | Text + | Web + deriving (Read, Show, Eq, Ord, Bounded, Enum) + +instance Text Category where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] + +#if MIN_VERSION_base(3,0,0) +#else +-- Compat instance for ghc-6.6 era +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) +#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs @@ -0,0 +1,940 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) 2005 David Himmelstrup +-- 2007 Bjorn Bringert +-- 2007-2010 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + install, + upgrade, + ) where + +import Data.List + ( unfoldr, find, nub, sort, partition ) +import Data.Maybe + ( isJust, fromMaybe ) +import qualified Data.Map as Map +import Control.Exception as Exception + ( handleJust ) +#if MIN_VERSION_base(4,0,0) +import Control.Exception as Exception + ( Exception(toException), catches, Handler(Handler), IOException ) +import System.Exit + ( ExitCode ) +#else +import Control.Exception as Exception + ( Exception(IOException, ExitException) ) +#endif +import Distribution.Compat.Exception + ( SomeException, catchIO, catchExit ) +import Control.Monad + ( when, unless ) +import System.Directory + ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>), takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode) ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress + , PackageConstraint(..), dependencyConstraints, dependencyTargets + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) + , Progress(..), foldProgress, ) +import Distribution.Client.Fetch + ( fetchPackage ) +import Distribution.Client.HttpUtils + ( downloadURI ) +import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +-- import qualified Distribution.Client.Info as Info +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup + ( GlobalFlags(..) + , ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) ) +import Distribution.Client.Config + ( defaultCabalDir ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Available + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), AvailablePackageDb(..) + , Repo(..), ConfiguredPackage(..) + , BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..), RemoteRepo(..) + , InstalledPackage ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +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 qualified Distribution.Client.World as World +import Paths_cabal_install (getBinDir) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..), emptyHaddockFlags + , buildCommand, BuildFlags(..), emptyBuildFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Cabal + ( installCommand, InstallFlags(..), emptyInstallFlags ) +import Distribution.Simple.Utils + ( defaultPackageDesc, rawSystemExit, comparing ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Package + ( PackageName(..), PackageIdentifier, packageName, packageVersion + , Package(..), PackageFixedDeps(..) + , Dependency(..), thisPackageVersion ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( Version, VersionRange, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, warn, die, intercalate, withTempDirectory ) +import Distribution.Client.Utils + ( inDir, mergeBy, MergeResult(..) ) +import Distribution.System + ( Platform, buildPlatform, OS(Windows), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, showForCabal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +--TODO: +-- * add --upgrade-deps flag +-- * add --only-deps flag +-- * eliminate upgrade, replaced by --upgrade-deps and world target +-- * assign flags to packages individually +-- * complain about flags that do not apply to any package given as target +-- so flags do not apply to dependencies, only listed, can use flag +-- constraints for dependencies +-- * only record applicable flags in world file +-- * allow flag constraints +-- * allow installed constraints +-- * allow flag and installed preferences +-- * change world file to use cabal section syntax +-- * allow persistent configure flags for each package individually + +-- ------------------------------------------------------------ +-- * Top level user actions +-- ------------------------------------------------------------ + +-- | An installation target given by the user. At the moment this +-- is just a named package, possibly with a version constraint. +-- It should be generalised to handle other targets like http or dirs. +-- +type InstallTarget = UnresolvedDependency + +-- | Installs the packages needed to satisfy a list of dependencies. +-- +install, upgrade + :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> [InstallTarget] + -> IO () +install verbosity packageDB repos comp conf + globalFlags configFlags configExFlags installFlags targets = + + installWithPlanner verbosity context planner targets + + where + context :: InstallContext + context = (packageDB, repos, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + + planner :: Planner + planner + | null targets = planLocalPackage verbosity + comp configFlags configExFlags + + | otherwise = planRepoPackages defaultPref + comp globalFlags configFlags configExFlags + installFlags targets + + defaultPref + | fromFlag (installUpgradeDeps installFlags) = PreferAllLatest + | otherwise = PreferLatestForSelected + + +upgrade _ _ _ _ _ _ _ _ _ _ = die $ + "Use the 'cabal install' command instead of 'cabal upgrade'.\n" + ++ "You can install the latest version of a package using 'cabal install'. " + ++ "The 'cabal upgrade' command has been removed because people found it " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." + + +type Planner = PackageIndex InstalledPackage + -> AvailablePackageDb + -> IO (Progress String String InstallPlan) + +type InstallContext = ( PackageDBStack + , [Repo] + , Compiler + , ProgramConfiguration + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags ) + +-- | Top-level orchestration. Installs the packages generated by a planner. +-- +installWithPlanner :: Verbosity + -> InstallContext + -> Planner + -> [UnresolvedDependency] + -> IO () +installWithPlanner verbosity + context@(packageDBs, repos, comp, conf, _, _, _, installFlags) + planner targets = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + available <- getAvailablePackages verbosity repos + + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg die return =<< planner installed available + + printPlanMessages verbosity installed installPlan dryRun + + unless dryRun $ + performInstallations verbosity context installed installPlan + >>= postInstallActions verbosity context targets + + where + dryRun = fromFlag (installDryRun installFlags) + logMsg message rest = info verbosity message >> rest + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity + -> Compiler + -> ConfigFlags + -> ConfigExFlags + -> Planner +planLocalPackage verbosity comp configFlags configExFlags installed + (AvailablePackageDb available availablePrefs) = 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) installed + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage Nothing + } + targets = [packageName pkg] + constraints = [PackageVersionConstraint (packageName pkg) + (thisVersion (packageVersion pkg)) + ,PackageFlagsConstraint (packageName pkg) + (configConfigurationsFlags configFlags)] + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs PreferLatestForSelected + availablePrefs configExFlags + + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available' preferences constraints targets + + +-- | Make an 'InstallPlan' for the given dependencies. +-- +planRepoPackages :: PackagesPreferenceDefault + -> Compiler + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> [UnresolvedDependency] + -> Planner +planRepoPackages defaultPref comp + globalFlags configFlags configExFlags installFlags + deps installed (AvailablePackageDb available availablePrefs) = do + + deps' <- addWorldPackages deps + >>= IndexUtils.disambiguateDependencies available + + let installed' + | fromFlag (installReinstall installFlags) + = hideGivenDeps deps' installed + | otherwise = installed + targets = dependencyTargets deps' + constraints = dependencyConstraints deps' + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs defaultPref availablePrefs configExFlags + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available preferences constraints targets + where + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + + addWorldPackages :: [UnresolvedDependency] -> IO [UnresolvedDependency] + addWorldPackages targets = case partition World.isWorldTarget targets of + ([], _) -> return targets + (world, otherTargets) -> do + unless (all World.isGoodWorldTarget world) $ + die $ "The virtual package 'world' does not take any version " + ++ "or configuration flags." + worldTargets <- World.getContents worldFile + --TODO: should we warn if there are no world targets? + return (otherTargets ++ worldTargets) + where + worldFile = fromFlag $ globalWorldFile globalFlags + + +mergePackagePrefs :: PackagesPreferenceDefault + -> Map.Map PackageName VersionRange + -> ConfigExFlags + -> PackagesPreference +mergePackagePrefs defaultPref availablePrefs configExFlags = + PackagesPreference defaultPref $ + -- The preferences that come from the hackage index + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + -- additional preferences from the config file or command line + ++ [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + + +-- ------------------------------------------------------------ +-- * Informational messages +-- ------------------------------------------------------------ + +printPlanMessages :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> Bool + -> IO () +printPlanMessages verbosity installed installPlan dryRun = do + + 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 installed installPlan + + where + nothingToInstall = null (InstallPlan.ready installPlan) + + +printDryRun :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO () +printDryRun verbosity installed plan = case unfoldr next plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + "In order, the following would be installed (use -v for more details):" + : map (display . packageId) pkgs + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just (pkg, 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 + + showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ + case PackageIndex.lookupPackageName installed (packageName pkg') of + [] -> "(new package)" + ps -> case find ((==packageId pkg') . packageId) ps of + Nothing -> "(new version)" + Just pkg -> "(reinstall)" ++ case changes pkg pkg' of + [] -> "" + diff -> " changes: " ++ intercalate ", " diff + changes pkg pkg' = map change . filter changed + $ mergeBy (comparing packageName) + (nub . sort . depends $ pkg) + (nub . sort . depends $ pkg') + change (OnlyInLeft pkgid) = display pkgid ++ " removed" + change (InBoth pkgid pkgid') = display pkgid ++ " -> " + ++ display (packageVersion pkgid') + change (OnlyInRight pkgid') = display pkgid' ++ " added" + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +-- ------------------------------------------------------------ +-- * Post installation stuff +-- ------------------------------------------------------------ + +-- | Various stuff we do after successful or unsuccessfully installing a bunch +-- of packages. This includes: +-- +-- * build reporting, local and remote +-- * symlinking binaries +-- * updating indexes +-- * updating world file +-- * error reporting +-- +postInstallActions :: Verbosity + -> InstallContext + -> [InstallTarget] + -> InstallPlan + -> IO () +postInstallActions verbosity + (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags) + targets installPlan = do + + unless oneShot $ + World.insert verbosity worldFile targets' + + let buildReports = BuildReports.fromInstallPlan installPlan + BuildReports.storeLocal (installSummaryFile installFlags) buildReports + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + + symlinkBinaries verbosity configFlags installFlags installPlan + + printBuildFailures installPlan + + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + oneShot = fromFlag (installOneShot installFlags) + worldFile = fromFlag $ globalWorldFile globalFlags + targets' = filter (not . World.isWorldTarget) targets + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- defaultCabalDir + let logFileName = display (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (BuildReports.show report, buildLog)) + + | (report, Repo { repoKind = Left remoteRepo }) <- reports + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + +#if MIN_VERSION_base(4,0,0) + missingFile ioe +#else + missingFile (IOException ioe) +#endif + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO () +regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installed <- getInstalledPackages verbosity comp packageDBs conf + Haddock.regenerateHaddockIndex verbosity installed conf indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index is per-user, we don't do it for global + -- installs or special cases where we're installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall + && someDocsWereInstalled installPlan + where + someDocsWereInstalled = any installedDocs . InstallPlan.toList + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + + installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True + installedDocs _ = False + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerId comp) + ++ InstallDirs.platformTemplateEnv (buildPlatform) + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +symlinkBinaries :: Verbosity + -> 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 = 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." + DownloadFailed e -> " failed while downloading the package." + ++ " The exception was:\n " ++ show e + 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 + + +-- ------------------------------------------------------------ +-- * Actually do the installations +-- ------------------------------------------------------------ + +data InstallMisc = InstallMisc { + rootCmd :: Maybe FilePath, + libVersion :: Maybe Version + } + +performInstallations :: Verbosity + -> InstallContext + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO InstallPlan +performInstallations verbosity + (packageDBs, _, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + installed installPlan = do + + executeInstallPlan installPlan $ \cpkg -> + installConfiguredPackage platform compid configFlags + cpkg $ \configFlags' src pkg -> + installAvailablePackage verbosity (packageId pkg) src $ \mpath -> + installUnpackedPackage verbosity (setupScriptOptions installed) + miscOptions configFlags' installFlags + compid pkg mpath useLogFile + + where + platform = InstallPlan.planPlatform installPlan + compid = InstallPlan.planCompiler installPlan + + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else let (db@GlobalPackageDB:dbs) = packageDBs + in db : UserPackageDB : dbs, + --TODO: use Ord instance: + -- insert UserPackageDB packageDBs + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + useLogFile :: Maybe (PackageIdentifier -> FilePath) + useLogFile = fmap substLogFileName logFileTemplate + where + logFileTemplate :: Maybe PathTemplate + logFileTemplate --TODO: separate policy from mechanism + | reportingLevel == DetailedReports + = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" + | otherwise + = flagToMaybe (installLogFile installFlags) + substLogFileName template pkg = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + miscOptions = InstallMisc { + rootCmd = if fromFlag (configUserInstall configFlags) + then Nothing -- ignore --root-cmd if --user. + else flagToMaybe (installRootCmd installFlags), + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + + +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 :: Platform -> CompilerId + -> ConfigFlags -> ConfiguredPackage + -> (ConfigFlags -> AvailablePackageSource + -> PackageDescription -> a) + -> a +installConfiguredPackage platform comp configFlags + (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) + installPkg = installPkg configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps + } source pkg + where + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + + +installAvailablePackage + :: Verbosity -> PackageIdentifier -> AvailablePackageSource + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installAvailablePackage _ _ (LocalUnpackedPackage dir) installPkg = + installPkg dir + +installAvailablePackage verbosity pkgid + (LocalTarballPackage tarballPath) installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> + installLocalTarballPackage verbosity pkgid + tarballPath tmpDirPath installPkg + +installAvailablePackage verbosity pkgid + (RemoteTarballPackage tarballURL) installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> + onFailure DownloadFailed $ do + let tarballPath = tmpDirPath display pkgid <.> "tar.gz" + --TODO: perhaps we've already had to download this to a local cache + -- so we even know what package version it is. So might be able + -- to get it from the local cache rather than from remote. + downloadURI verbosity tarballURL tarballPath + installLocalTarballPackage verbosity pkgid + tarballPath tmpDirPath installPkg + +installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = + onFailure DownloadFailed $ do + tarballPath <- fetchPackage verbosity repo pkgid + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> + installLocalTarballPackage verbosity pkgid + tarballPath tmpDirPath installPkg + +installLocalTarballPackage + :: Verbosity -> PackageIdentifier -> FilePath -> FilePath + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installLocalTarballPackage verbosity pkgid tarballPath tmpDirPath installPkg = + onFailure UnpackFailed $ do + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + let relUnpackedPath = display pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = absUnpackedPath + display (packageName pkgid) <.> "cabal" + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath + installPkg (Just absUnpackedPath) + + +installUnpackedPackage :: Verbosity + -> SetupScriptOptions + -> InstallMisc + -> 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 (do setup haddockCommand haddockFlags + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + 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 { + configVerbosity = toFlag verbosity' + } + buildCommand' = buildCommand defaultProgramConfiguration + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installConfigFlags) + haddockFlags _ = emptyHaddockFlags { + haddockDistPref = configDistPref configFlags, + haddockVerbosity = toFlag verbosity' + } + installFlags _ = Cabal.emptyInstallFlags { + Cabal.installDistPref = configDistPref configFlags, + Cabal.installVerbosity = toFlag verbosity' + } + verbosity' | isJust useLogFile = max Verbosity.verbose verbosity + | otherwise = verbosity + setup cmd flags = do + logFileHandle <- case useLogFile of + Nothing -> return Nothing + Just mkLogFileName -> do + let logFileName = mkLogFileName (packageId pkg) + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFile <- openFile logFileName AppendMode + return (Just logFile) + + 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 :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult +onFailure result action = +#if MIN_VERSION_base(4,0,0) + action `catches` + [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] + where + handler :: Exception e => e -> IO BuildResult + handler = return . Left . result . toException +#else + action + `catchIO` (return . Left . result . IOException) + `catchExit` (return . Left . result . ExitException) +#endif + + +-- ------------------------------------------------------------ +-- * Wierd windows hacks +-- ------------------------------------------------------------ + +withWin32SelfUpgrade :: Verbosity + -> ConfigFlags + -> CompilerId + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = 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 = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (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/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs @@ -0,0 +1,495 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + planPlatform, + 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(..) + , InstalledPackage + , BuildFailure, BuildSuccess ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , PackageFixedDeps(..), Dependency(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.PackageDescription + ( GenericPackageDescription(genPackageFlags) + , Flag(flagName), FlagName(..) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Text + ( display ) +import Distribution.System + ( Platform ) +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 InstalledPackage + | 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, + planPkgOf :: Graph.Vertex -> PlanPackage, + planVertexOf :: PackageIdentifier -> Graph.Vertex, + planPlatform :: Platform, + planCompiler :: CompilerId + } + +invariant :: InstallPlan -> Bool +invariant plan = + valid (planPlatform 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 :: Platform -> CompilerId -> PackageIndex PlanPackage + -> Either [PlanProblem] InstallPlan +new platform compiler index = + case problems platform compiler index of + [] -> Right InstallPlan { + planIndex = index, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planPlatform = platform, + 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 checkConfiguredPackage + $ packagesThatDependOn plan pkgid ] + +-- | lookup the reachable packages in the reverse dependency graph +-- +packagesThatDependOn :: InstallPlan + -> PackageIdentifier -> [PlanPackage] +packagesThatDependOn plan = map (planPkgOf 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 + +-- | check a package that we expect to be in the configured or failed state +-- +checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage +checkConfiguredPackage (Configured pkg) = Just pkg +checkConfiguredPackage (Failed _ _) = Nothing +checkConfiguredPackage pkg = + internalError $ "not configured or no such pkg " ++ display (packageId pkg) + +-- ------------------------------------------------------------ +-- * 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 :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool +valid platform comp index = null (problems platform comp index) + +data PlanProblem = + PackageInvalid ConfiguredPackage [PackageProblem] + | PackageMissingDeps PlanPackage [PackageIdentifier] + | PackageCycle [PlanPackage] + | PackageInconsistency PackageName [(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 " ++ display 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 :: Platform -> CompilerId + -> PackageIndex PlanPackage -> [PlanProblem] +problems platform comp index = + [ PackageInvalid pkg packageProblems + | Configured pkg <- PackageIndex.allPackages index + , let packageProblems = configuredPackageProblems platform 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 :: Platform -> CompilerId -> ConfiguredPackage -> Bool +configuredPackageValid platform comp pkg = + null (configuredPackageProblems platform 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 :: Platform -> CompilerId + -> ConfiguredPackage -> [PackageProblem] +configuredPackageProblems platform 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 + (const True) + platform comp + [] + (packageDescription pkg) of + Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg + Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,238 @@ +{-# 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 System.Posix.Files + ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink + , removeLink ) +import System.Directory + ( canonicalizePath ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import Prelude hiding (catch, ioError) +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 + (const True) + platform 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) + platform = InstallPlan.planPlatform 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 privateName) + 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 target (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 binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + status <- getSymbolicLinkStatus symlink + if not (isSymbolicLink status) + then return NotOurFile + else do target' <- canonicalizePath symlink + -- This relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile + + 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/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs @@ -0,0 +1,368 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Distribution.Package + ( PackageName(..), packageName, packageVersion + , Dependency(..), thisPackageVersion, depends ) +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Available +import Distribution.PackageDescription + ( Flag(..), FlagName(..) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Utils (equating, comparing, notice) +import Distribution.Simple.Setup (fromFlag) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Version (Version) +import Distribution.Verbosity (Verbosity) +import Distribution.Text + ( Text(disp), display ) + +import Distribution.Client.Types + ( AvailablePackage(..), Repo, AvailablePackageDb(..) + , UnresolvedDependency(..), InstalledPackage(..) ) +import Distribution.Client.Setup + ( ListFlags(..), InfoFlags(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import Distribution.Client.Fetch + ( isFetched ) + +import Data.List + ( sortBy, groupBy, sort, nub, intersperse, maximumBy ) +import Data.Maybe + ( listToMaybe, fromJust, fromMaybe, isJust, isNothing ) +import Control.Monad + ( MonadPlus(mplus), join ) +import Control.Exception + ( assert ) +import Text.PrettyPrint.HughesPJ as Disp +import System.Directory + ( doesDirectoryExist ) + + +-- |Show information about packages +list :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos comp conf listFlags pats = do + installed <- getInstalledPackages verbosity comp packageDBs conf + AvailablePackageDb 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 + [ display (pkgname 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 showPackageSummaryInfo matches) + where + installedFilter + | onlyInstalled = filter (not . null . installedVersions) + | otherwise = id + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + +info :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> InfoFlags + -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint + -> IO () +info verbosity packageDBs repos comp conf _listFlags deps = do + AvailablePackageDb available _ <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available deps + installed <- getInstalledPackages verbosity comp packageDBs conf + let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ] + let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps'' + ,concatMap (PackageIndex.lookupPackageName available) deps'') + pkgsinfo = map (uncurry mergePackageInfo) + $ uncurry mergePackages pkgs + + pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo + putStr $ unlines (map showPackageDetailedInfo pkgsinfo') + +-- | 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 { + pkgname :: PackageName, + allInstalled :: [InstalledPackage], + allAvailable :: [AvailablePackage], + latestInstalled :: Maybe InstalledPackage, + latestAvailable :: Maybe AvailablePackage, + homepage :: String, + bugReports :: String, + sourceRepo :: String, + synopsis :: String, + description :: String, + category :: String, + license :: License, +-- copyright :: String, --TODO: is this useful? + author :: String, + maintainer :: String, + dependencies :: [Dependency], + flags :: [Flag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [String], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +installedVersions :: PackageDisplayInfo -> [Version] +installedVersions = map packageVersion . allInstalled + +availableVersions :: PackageDisplayInfo -> [Version] +availableVersions = map packageVersion . allAvailable + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgname pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Latest version available:" <+> + case latestAvailable pkginfo of + Nothing -> text "[ Not available from server ]" + Just pkg -> disp (packageVersion pkg) + , text "Latest version installed:" <+> + case latestInstalled pkginfo of + Nothing | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + Just pkg -> disp (packageVersion pkg) + , maybeShow (homepage pkginfo) "Homepage:" text + , text "License: " <+> text (display (license pkginfo)) + ]) + $+$ text "" + where + maybeShow [] _ _ = empty + maybeShow l s f = text s <+> (f l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgname pkginfo) + <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ') + <> parens pkgkind + $+$ + (nest 4 $ vcat [ + entry "Synopsis" synopsis alwaysShow reflowParagraphs + , entry "Latest version available" latestAvailable + (altText isNothing "[ Not available from server ]") + (disp . packageVersion . fromJust) + , entry "Latest version installed" latestInstalled + (altText isNothing (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (disp . packageVersion . fromJust) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description alwaysShow reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep disp) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then empty else + text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> empty + Just (Just other) -> label <+> text other + where + label = text fname <> char ':' <> padding + padding = text (replicate (13 - length fname ) ' ') + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag f = case flagName f of FlagName n -> text n + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = empty + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . 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 :: [InstalledPackage] + -> [AvailablePackage] + -> PackageDisplayInfo +mergePackageInfo installedPkgs availablePkgs = + assert (length installedPkgs + length availablePkgs > 0) $ + PackageDisplayInfo { + pkgname = combine packageName available + packageName installed, + allInstalled = installedPkgs, + allAvailable = availablePkgs, + latestInstalled = latest installedPkgs, + latestAvailable = latest availablePkgs, + license = combine Available.license available + Installed.license installed, + maintainer = combine Available.maintainer available + Installed.maintainer installed, + author = combine Available.author available + Installed.author installed, + homepage = combine Available.homepage available + Installed.homepage installed, + bugReports = maybe "" Available.bugReports available, + sourceRepo = fromMaybe "" . join + . fmap (uncons Nothing Available.repoLocation + . sortBy (comparing Available.repoKind) + . Available.sourceRepos) + $ available, + synopsis = combine Available.synopsis available + Installed.description installed, + description = combine Available.description available + Installed.description installed, + category = combine Available.category available + Installed.category installed, + flags = maybe [] Available.genPackageFlags availableGeneric, + hasLib = isJust installed + || fromMaybe False + (fmap (isJust . Available.condLibrary) availableGeneric), + hasExe = fromMaybe False + (fmap (not . null . Available.condExecutables) availableGeneric), + executables = map fst (maybe [] Available.condExecutables availableGeneric), + modules = combine Installed.exposedModules installed + (maybe [] Available.exposedModules + . Available.library) available, + dependencies = combine Available.buildDepends available + (map thisPackageVersion . depends) installed', + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed' = latest installedPkgs + installed = fmap (\(InstalledPackage p _) -> p) installed' + availableGeneric = fmap packageDescription (latest availablePkgs) + available = fmap flattenPackageDescription availableGeneric + latest [] = Nothing + latest pkgs = Just (maximumBy (comparing packageVersion) pkgs) + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) isFetched (latestAvailable pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +-- | 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 :: [InstalledPackage] -> [AvailablePackage] + -> [([InstalledPackage], [AvailablePackage])] +mergePackages installed available = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installed) + (groupOn packageName 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/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs @@ -0,0 +1,479 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Client.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List (groupBy, sortBy, nub, find, isInfixOf) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion + , Dependency(Dependency), PackageFixedDeps(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, equating, comparing) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched effeciently by package name and version. +-- +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Show, Read) + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex (Map.empty) + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: Package pkg => PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] +searchByName (PackageIndex m) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] of + [] -> None + [(_,pkgs)] -> Unambiguous pkgs + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pkgs) -> Unambiguous pkgs + Nothing -> Ambiguous (map snd pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkg + | (PackageName name, pkgs) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + +-- | All packages that have dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(pkg, [PackageIdentifier])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- depends pkg + , isNothing (lookupPackageId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transative closure of the package dependencies. +-- +-- If the transative closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageIdentifier's do not occur in the index. +-- +dependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> Either (PackageIndex pkg) + [(pkg, [PackageIdentifier])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupPackageId completed (packageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = depends pkg ++ pkgids + +-- | Takes the transative closure of the packages reverse dependencies. +-- +-- * The given 'PackageIdentifier's must be in the index. +-- +reverseDependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> [pkg] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies index = + [ (name, inconsistencies) + | (name, uses) <- Map.toList inverseIndex + , let inconsistencies = duplicatesBy uses + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] + + where inverseIndex = Map.fromListWith (++) + [ (packageName dep, [(packageId pkg, packageVersion dep)]) + | pkg <- allPackages index + , dep <- depends pkg ] + + duplicatesBy = (\groups -> if length groups == 1 + then [] + else concat groups) + . groupBy (equating snd) + . sortBy (comparing snd) + + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageFixedDeps pkg + => PackageIndex pkg + -> [[pkg]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, packageId pkg, depends pkg) + | pkg <- allPackages index ] + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageFixedDeps pkg + => PackageIndex pkg + -> (Graph.Graph, + Graph.Vertex -> pkg, + PackageIdentifier -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] + | pkg <- pkgs ] + vertexToPkg vertex = pkgTable ! vertex + pkgIdToVertex = binarySearch 0 topBound + + pkgTable = Array.listArray bounds pkgs + pkgIdTable = Array.listArray bounds (map packageId pkgs) + pkgs = sortBy (comparing packageId) (allPackages index) + topBound = length pkgs - 1 + bounds = (0, topBound) + + binarySearch a b key + | a > b = Nothing + | otherwise = case compare key (pkgIdTable ! mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just mid + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageUtils +-- Copyright : (c) Duncan Coutts 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Various package description utils that should be in the Cabal lib +----------------------------------------------------------------------------- +module Distribution.Client.PackageUtils ( + externalBuildDepends, + ) where + +import Distribution.Package + ( packageVersion, packageName, Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..) ) +import Distribution.Version + ( withinRange ) + +-- | The list of dependencies that refer to external packages +-- rather than internal package components. +-- +externalBuildDepends :: PackageDescription -> [Dependency] +externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) + where + -- True if this dependency is an internal one (depends on a library + -- defined in the same package). + internal (Dependency depName versionRange) = + depName == packageName pkg && + packageVersion pkg `withinRange` versionRange diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs @@ -0,0 +1,952 @@ +----------------------------------------------------------------------------- +-- | +-- 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, ConfigFlags(..), filterConfigureFlags + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , configureExOptions + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , listCommand, ListFlags(..) + , updateCommand + , upgradeCommand + , infoCommand, InfoFlags(..) + , fetchCommand, FetchFlags(..) + , checkCommand + , uploadCommand, UploadFlags(..) + , reportCommand + , unpackCommand, UnpackFlags(..) + , initCommand, IT.InitFlags(..) + + , parsePackageArgs + --TODO: stop exporting these: + , showRepo + , parseRepo + ) where + +import Distribution.Client.Types + ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..), PackageType(..) ) + +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 + ( configureCommand ) +import Distribution.Simple.Setup + ( ConfigFlags(..) ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe + , optionVerbosity, trueArg, falseArg ) +import Distribution.Simple.InstallDirs + ( PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Version + ( Version(Version), anyVersion, thisVersion ) +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 Distribution.Simple.Utils + ( wrapText ) + +import Data.Char + ( isSpace, isAlphaNum ) +import Data.Maybe + ( listToMaybe, maybeToList, fromMaybe ) +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], + globalLogsDir :: Flag FilePath, + globalWorldFile :: Flag FilePath + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This program is the command line interface " + ++ "to the Haskell Cabal infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + 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) + + ,option [] ["logs-dir"] + "The location to put log files" + globalLogsDir (\v flags -> flags { globalLogsDir = v }) + (reqArgFlag "DIR") + + ,option [] ["world-file"] + "The location of the world file" + globalWorldFile (\v flags -> flags { globalWorldFile = v }) + (reqArgFlag "FILE") + ] + } + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalRemoteRepos = combine globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = combine globalLocalRepos, + globalLogsDir = combine globalLogsDir, + globalWorldFile = combine globalWorldFile + } + 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 ConfigFlags +configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + | cabalLibVersion >= Version [1,3,10] [] = flags + -- older Cabal does not grok the constraints flag: + | otherwise = flags { configConstraints = [] } + + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configPreferences :: [Dependency] + } + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (configureOptions showOrParseArgs) + ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) + (fmap toFlag parse)) + (map display . flagToList)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ] + +instance Monoid ConfigExFlags where + mempty = ConfigExFlags { + configCabalVersion = mempty, + configPreferences = mempty + } + mappend a b = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + configPreferences = combine configPreferences + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Fetch command +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags { +-- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool, + fetchDryRun :: Flag Bool, + fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = FetchFlags { +-- fetchOutput = mempty, + fetchDeps = toFlag True, + fetchDryRun = toFlag False, + fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandDescription = Nothing, + commandUsage = usagePackages "fetch", + commandDefaultFlags = defaultFetchFlags, + commandOptions = \_ -> [ + optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) + +-- , option "o" ["output"] +-- "Put the package(s) somewhere specific rather than the usual cache." +-- fetchOutput (\v flags -> flags { fetchOutput = v }) +-- (reqArgFlag "PATH") + + , option [] ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps (\v flags -> flags { fetchDeps = v }) + trueArg + + , option [] ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps (\v flags -> flags { fetchDeps = v }) + falseArg + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun (\v flags -> flags { fetchDryRun = v }) + trueArg + ] + } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +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 (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeCommand = configureCommand { + commandName = "upgrade", + commandSynopsis = "(command disabled, use install instead)", + commandDescription = Nothing, + commandUsage = usagePackages "upgrade", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = commandOptions installCommand + } + +{- +cleanCommand :: CommandUI () +cleanCommand = makeCommand name shortDesc longDesc emptyFlags options + where + name = "clean" + shortDesc = "Removes downloaded files" + longDesc = Nothing + emptyFlags = () + options _ = [] +-} + +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 = \_ -> [] + } + +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] + } + +-- ------------------------------------------------------------ +-- * Unpack flags +-- ------------------------------------------------------------ + +data UnpackFlags = UnpackFlags { + unpackDestDir :: Flag FilePath, + unpackVerbosity :: Flag Verbosity + } + +defaultUnpackFlags :: UnpackFlags +defaultUnpackFlags = UnpackFlags { + unpackDestDir = mempty, + unpackVerbosity = toFlag normal + } + +unpackCommand :: CommandUI UnpackFlags +unpackCommand = CommandUI { + commandName = "unpack", + commandSynopsis = "Unpacks packages for user inspection.", + commandDescription = Nothing, + commandUsage = usagePackages "unpack", + commandDefaultFlags = mempty, + commandOptions = \_ -> [ + optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) + + ,option "d" ["destdir"] + "where to unpack the packages, defaults to the current directory." + unpackDestDir (\v flags -> flags { unpackDestDir = v }) + (reqArgFlag "PATH") + ] + } + +instance Monoid UnpackFlags where + mempty = defaultUnpackFlags + mappend a b = UnpackFlags { + unpackDestDir = combine unpackDestDir + ,unpackVerbosity = combine unpackVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * 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 packages matching a search string.", + 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 + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity + } + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Nothing, + commandUsage = usagePackages "info", + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + ] + } + +instance Monoid InfoFlags where + mempty = defaultInfoFlags + mappend a b = InfoFlags { + infoVerbosity = combine infoVerbosity + } + 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, + installHaddockIndex :: Flag PathTemplate, + installDryRun :: Flag Bool, + installReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installRootCmd :: Flag String, + installSummaryFile :: [PathTemplate], + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installSymlinkBinDir:: Flag FilePath, + installOneShot :: Flag Bool + } + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation= Flag False, + installHaddockIndex = Flag docIndexFile, + installDryRun = Flag False, + installReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installSymlinkBinDir= mempty, + installOneShot = Flag False + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Installs a list of packages.", + commandUsage = usagePackages "install", + commandDescription = Just $ \pname -> + let original = case commandDescription configureCommand of + Just desc -> desc pname ++ "\n" + Nothing -> "" + in original + ++ "Examples:\n" + ++ " " ++ pname ++ " install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " install 'foo < 2' " + ++ " Constrained package version\n", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) + ++ liftOptions get3 set3 (installOptions showOrParseArgs) + } + where + get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) + get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) + get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , 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 [] ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps (\v flags -> flags { installUpgradeDeps = 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 [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["one-shot"] + "Do not record the packages in the world file." + installOneShot (\v flags -> flags { installOneShot = 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, + installHaddockIndex = mempty, + installDryRun = mempty, + installReinstall = mempty, + installUpgradeDeps = mempty, + installOnly = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir= mempty, + installOneShot = mempty + } + mappend a b = InstallFlags { + installDocumentation= combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installUpgradeDeps = combine installUpgradeDeps, + installOnly = combine installOnly, + installRootCmd = combine installRootCmd, + installSummaryFile = combine installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir= combine installSymlinkBinDir, + installOneShot = combine installOneShot + } + 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 + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +emptyInitFlags :: IT.InitFlags +emptyInitFlags = mempty + +defaultInitFlags :: IT.InitFlags +defaultInitFlags = emptyInitFlags + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Interactively create a .cabal file.", + commandDescription = Just $ \_ -> wrapText $ + "Cabalise a project by creating a .cabal, Setup.hs, and " + ++ "optionally a LICENSE file.\n\n" + ++ "Calling init with no arguments (recommended) uses an " + ++ "interactive mode, which will try to guess as much as " + ++ "possible and prompt you for the rest. Command-line " + ++ "arguments are provided for scripting purposes. " + ++ "If you don't want interactive mode, be sure to pass " + ++ "the -n flag.\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [FLAGS]\n\n" + ++ "Flags for init:", + commandDefaultFlags = defaultInitFlags, + commandOptions = \_ -> + [ option ['n'] ["non-interactive"] + "Non-interactive mode." + IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) + trueArg + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["package-dir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArgFlag "PACKAGE") + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["cabal-version"] + "Required version of the Cabal library." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) + + , option [] ["is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option [] ["source-dir"] + "Directory containing package source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + ] + } + where readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- ------------------------------------------------------------ +-- * 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 + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +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 $ + show arg ++ " is not valid syntax for a package name or" + ++ " package dependency." + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + +parseDependencyOrPackageId :: Parse.ReadP r Dependency +parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse + where + 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/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,320 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Distribution.Client.Types + ( InstalledPackage ) + +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version(..), VersionRange, anyVersion + , intersectVersionRanges, orLaterVersion + , withinRange ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , packageVersion, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), specVersion, BuildType(..) ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Configure + ( configCompiler ) +import Distribution.Simple.Compiler + ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) +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.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Simple.Utils + ( die, debug, info, cabalVersion, findPackageDesc, comparing + , createDirectoryIfMissingVerbose, rewriteFile ) +import Distribution.Client.Utils + ( moreRecentFile, inDir ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Process ( runProcess, waitForProcess ) +import Control.Monad ( when, unless ) +import Data.List ( maximumBy ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Char ( isSpace ) + +data SetupScriptOptions = SetupScriptOptions { + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe (PackageIndex InstalledPackage), + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCompiler = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + 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) + (orLaterVersion (specVersion 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 = case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + 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 == PackageName "Cabal" = + return (packageVersion pkg) + installedCabalVersion options' comp conf = do + index <- case usePackageIndex options' of + Just index -> return index + Nothing -> getInstalledPackages verbosity + comp (usePackageDB options') conf + + let cabalDep = Dependency (PackageName "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' + --TODO: get Cabal's GHC module to export a GhcOptions type and render func + rawSystemProgramConf verbosity ghcProgram conf $ + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ ghcPackageDbOptions (usePackageDB options') + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + where + cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + + ghcPackageDbOptions :: PackageDBStack -> [String] + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + + 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 diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/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, snapshotPackage ) +import Distribution.Client.Tar (createTarGzFile) + +import Distribution.Package + ( Package(..) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Utils + ( defaultPackageDesc, warn, notice, setupMessage + , createDirectoryIfMissingVerbose, withTempDirectory ) +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 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 tmpTargetDir = srcPref distPref + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + + _ <- if snapshot + then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps + else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps + 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) + pps = knownSuffixHandlers + +-- |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/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs @@ -0,0 +1,871 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * High level \"all in one\" operations + createTarGzFile, + extractTarGzFile, + + -- * Converting between internal and external representation + read, + write, + + -- * Packing and unpacking files to\/from internal representation + pack, + unpack, + + -- * Tar entry and associated types + Entry(..), + entryPath, + EntryContent(..), + Ownership(..), + FileSize, + Permissions, + EpochTime, + DevMajor, + DevMinor, + TypeCode, + Format(..), + + -- * Constructing simple entry values + simpleEntry, + fileEntry, + directoryEntry, + + -- * TarPath type + TarPath, + toTarPath, + fromTarPath, + + -- ** Sequences of tar entries + Entries(..), + foldEntries, + unfoldEntries, + mapEntries, + + ) where + +import Data.Char (ord) +import Data.Int (Int64) +import Data.Bits (Bits, shiftL) +import Data.List (foldl') +import Numeric (readOct, showOct) +import Control.Monad (MonadPlus(mplus)) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip +import qualified Distribution.Client.GZipUtils as GZipUtils + +import System.FilePath + ( () ) +import qualified System.FilePath as FilePath.Native +import qualified System.FilePath.Windows as FilePath.Windows +import qualified System.FilePath.Posix as FilePath.Posix +import System.Directory + ( getDirectoryContents, doesDirectoryExist, getModificationTime + , getPermissions, createDirectoryIfMissing, copyFile ) +import qualified System.Directory as Permissions + ( Permissions(executable) ) +import System.Posix.Types + ( FileMode ) +import System.Time + ( ClockTime(..) ) +import System.IO + ( IOMode(ReadMode), openBinaryFile, hFileSize ) +import System.IO.Unsafe (unsafeInterleaveIO) + +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 = + BS.writeFile tar . GZip.compress . write =<< pack base [dir] + +extractTarGzFile :: FilePath -- ^ Destination directory + -> FilePath -- ^ Expected subdir (to check for tarbombs) + -> FilePath -- ^ Tarball + -> IO () +extractTarGzFile dir expected tar = do + unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar + +-- +-- * Entry type +-- + +type FileSize = Int64 +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 +type DevMajor = Int +type DevMinor = Int +type TypeCode = Char +type Permissions = FileMode + +-- | Tar archive entry. +-- +data Entry = Entry { + + -- | The path of the file or directory within the archive. This is in a + -- tar-specific form. Use 'entryPath' to get a native 'FilePath'. + entryTarPath :: !TarPath, + + -- | The real content of the entry. For 'NormalFile' this includes the + -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. + entryContent :: !EntryContent, + + -- | File permissions (Unix style file mode). + entryPermissions :: !Permissions, + + -- | The user and group to which this file belongs. + entryOwnership :: !Ownership, + + -- | The time the file was last modified. + entryTime :: !EpochTime, + + -- | The tar format the archive is using. + entryFormat :: !Format + } + +-- | Native 'FilePath' of the file or directory within the archive. +-- +entryPath :: Entry -> FilePath +entryPath = fromTarPath . entryTarPath + +-- | The content of a tar archive entry, which depends on the type of entry. +-- +-- Portable archives should contain only 'NormalFile' and 'Directory'. +-- +data EntryContent = NormalFile ByteString !FileSize + | Directory + | SymbolicLink !LinkTarget + | HardLink !LinkTarget + | CharacterDevice !DevMajor !DevMinor + | BlockDevice !DevMajor !DevMinor + | NamedPipe + | OtherEntryType !TypeCode ByteString !FileSize + +data Ownership = Ownership { + -- | The owner user name. Should be set to @\"\"@ if unknown. + ownerName :: String, + + -- | The owner group name. Should be set to @\"\"@ if unknown. + groupName :: String, + + -- | Numeric owner user id. Should be set to @0@ if unknown. + ownerId :: !Int, + + -- | Numeric owner group id. Should be set to @0@ if unknown. + groupId :: !Int + } + +-- | There have been a number of extensions to the tar file format over the +-- years. They all share the basic entry fields and put more meta-data in +-- different extended headers. +-- +data Format = + + -- | This is the classic Unix V7 tar format. It does not support owner and + -- group names, just numeric Ids. It also does not support device numbers. + V7Format + + -- | The \"USTAR\" format is an extension of the classic V7 format. It was + -- later standardised by POSIX. It has some restructions but is the most + -- portable format. + -- + | UstarFormat + + -- | The GNU tar implementation also extends the classic V7 format, though + -- in a slightly different way from the USTAR format. In general for new + -- archives the standard USTAR/POSIX should be used. + -- + | GnuFormat + deriving Eq + +-- | @rw-r--r--@ for normal files +ordinaryFilePermissions :: Permissions +ordinaryFilePermissions = 0o0644 + +-- | @rwxr-xr-x@ for executable files +executableFilePermissions :: Permissions +executableFilePermissions = 0o0755 + +-- | @rwxr-xr-x@ for directories +directoryPermissions :: Permissions +directoryPermissions = 0o0755 + +-- | An 'Entry' with all default values except for the file name and type. It +-- uses the portable USTAR/POSIX format (see 'UstarHeader'). +-- +-- You can use this as a basis and override specific fields, eg: +-- +-- > (emptyEntry name HardLink) { linkTarget = target } +-- +simpleEntry :: TarPath -> EntryContent -> Entry +simpleEntry tarpath content = Entry { + entryTarPath = tarpath, + entryContent = content, + entryPermissions = case content of + Directory -> directoryPermissions + _ -> ordinaryFilePermissions, + entryOwnership = Ownership "" "" 0 0, + entryTime = 0, + entryFormat = UstarFormat + } + +-- | A tar 'Entry' for a file. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +-- You can use this as a basis and override specific fields. For example if you +-- need an executable file you could use: +-- +-- > (fileEntry name content) { fileMode = executableFileMode } +-- +fileEntry :: TarPath -> ByteString -> Entry +fileEntry name fileContent = + simpleEntry name (NormalFile fileContent (BS.length fileContent)) + +-- | A tar 'Entry' for a directory. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +directoryEntry :: TarPath -> Entry +directoryEntry name = simpleEntry name Directory + +-- +-- * Tar paths +-- + +-- | The classic tar format allowed just 100 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 old tar +-- programs that only understand the classic format. A classic tar would be +-- able to extract the file name and possibly some dir prefix, but not the +-- full dir prefix. So the files would end up in the wrong place, but that's +-- probably better than ending up with the wrong names too. +-- +-- So it's understandable but rather annoying. +-- +-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective +-- of the local path conventions. +-- +-- * The directory separator between the prefix and name is /not/ stored. +-- +data TarPath = TarPath FilePath -- path name, 100 characters max. + FilePath -- path prefix, 155 characters max. + deriving (Eq, Ord) + +-- | Convert a 'TarPath' to a native 'FilePath'. +-- +-- The native 'FilePath' will use the native directory separator but it is not +-- otherwise checked for validity or sanity. In particular: +-- +-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is +-- not valid on Windows. +-- +-- * The tar path may be an absolute path or may contain @\"..\"@ components. +-- For security reasons this should not usually be allowed, but it is your +-- responsibility to check for these conditions (eg using 'checkSecurity'). +-- +fromTarPath :: TarPath -> FilePath +fromTarPath (TarPath name prefix) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix + ++ FilePath.Posix.splitDirectories name + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- | Convert a native 'FilePath' to a 'TarPath'. +-- +-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a +-- description of the problem with splitting long 'FilePath's. +-- +toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for + -- directories a 'TarPath' must always use a trailing @\/@. + -> FilePath -> Either String TarPath +toTarPath isDir = splitLongPath + . addTrailingSep + . FilePath.Posix.joinPath + . FilePath.Native.splitDirectories + where + addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator + | otherwise = id + +-- | Take a sanitized path, split on directory separators and try to pack it +-- into the 155 + 100 tar file name format. +-- +-- The 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) + +-- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and +-- 'HardLink' entry types. +-- +newtype LinkTarget = LinkTarget FilePath + deriving (Eq, Ord) + +-- | Convert a tar 'LinkTarget' to a native 'FilePath'. +-- +fromLinkTarget :: LinkTarget -> FilePath +fromLinkTarget (LinkTarget path) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- +-- * Entries type +-- + +-- | A tar archive is a sequence of entries. +data Entries = Next Entry Entries + | Done + | Fail String + +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 +-- + +-- | This function checks a sequence of tar entries for file name security +-- problems. It checks that: +-- +-- * file paths are not absolute +-- +-- * file paths do not contain any path components that are \"@..@\" +-- +-- * file names are valid +-- +-- These checks are from the perspective of the current OS. That means we check +-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive +-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the +-- link target. A failure in any entry terminates the sequence of entries with +-- an error. +-- +checkSecurity :: Entries -> Entries +checkSecurity = checkEntries checkEntrySecurity + +checkTarbomb :: FilePath -> Entries -> Entries +checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) + +checkEntrySecurity :: Entry -> Maybe String +checkEntrySecurity entry = case entryContent entry of + HardLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + SymbolicLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + _ -> check (entryPath entry) + + where + check name + | not (FilePath.Native.isRelative name) + = Just $ "Absolute file name in tar archive: " ++ show name + + | not (FilePath.Native.isValid name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | any (=="..") (FilePath.Native.splitDirectories name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | otherwise = Nothing + +checkEntryTarbomb :: FilePath -> Entry -> Maybe String +checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing + where + -- Ignore some special entries we will not unpack anyway + nonFilesystemEntry = + case entryContent entry of + OtherEntryType 'g' _ _ -> True --PAX global header + OtherEntryType 'x' _ _ -> True --PAX individual header + _ -> False + +checkEntryTarbomb expectedTopDir entry = + case FilePath.Native.splitDirectories (entryPath entry) of + (topDir:_) | topDir == expectedTopDir -> Nothing + _ -> Just $ "File in tar archive is not in the expected directory " + ++ show expectedTopDir + +checkEntries :: (Entry -> Maybe String) -> Entries -> Entries +checkEntries checkEntry = + mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry)) + +-- +-- * Reading +-- + +read :: ByteString -> Entries +read = unfoldEntries getEntry + +getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry bs + | BS.length header < 512 = Left "truncated tar archive" + + -- Tar files end with at least two blocks of all '0'. Checking this serves + -- two purposes. It checks the format but also forces the tail of the data + -- which is necessary to close the file if it came from a lazily read file. + | BS.head bs == 0 = case BS.splitAt 1024 bs of + (end, trailing) + | BS.length end /= 1024 -> Left "short tar trailer" + | not (BS.all (== 0) end) -> Left "bad tar trailer" + | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" + | otherwise -> Right Nothing + + | otherwise = partial $ do + + case (chksum_, format_) of + (Ok chksum, _ ) | correctChecksum header chksum -> return () + (Ok _, Ok _) -> fail "tar checksum error" + _ -> fail "data is not in tar format" + + -- These fields are partial, have to check them + format <- format_; mode <- mode_; + uid <- uid_; gid <- gid_; + size <- size_; mtime <- mtime_; + devmajor <- devmajor_; devminor <- devminor_; + + let content = BS.take size (BS.drop 512 bs) + padding = (512 - size) `mod` 512 + bs' = BS.drop (512 + size + padding) bs + + entry = Entry { + entryTarPath = TarPath name prefix, + entryContent = case typecode of + '\0' -> NormalFile content size + '0' -> NormalFile content size + '1' -> HardLink (LinkTarget linkname) + '2' -> SymbolicLink (LinkTarget linkname) + '3' -> CharacterDevice devmajor devminor + '4' -> BlockDevice devmajor devminor + '5' -> Directory + '6' -> NamedPipe + '7' -> NormalFile content size + _ -> OtherEntryType typecode content size, + entryPermissions = mode, + entryOwnership = Ownership uname gname uid gid, + entryTime = mtime, + entryFormat = format + } + + return (Just (entry, bs')) + + where + header = BS.take 512 bs + + name = getString 0 100 header + mode_ = getOct 100 8 header + uid_ = getOct 108 8 header + gid_ = getOct 116 8 header + size_ = getOct 124 12 header + mtime_ = getOct 136 12 header + chksum_ = getOct 148 8 header + typecode = getByte 156 header + linkname = getString 157 100 header + magic = getChars 257 8 header + uname = getString 265 32 header + gname = getString 297 32 header + devmajor_ = getOct 329 8 header + devminor_ = getOct 337 8 header + prefix = getString 345 155 header +-- trailing = getBytes 500 12 header + + format_ = case magic of + "\0\0\0\0\0\0\0\0" -> return V7Format + "ustar\NUL00" -> return UstarFormat + "ustar \NUL" -> return GnuFormat + _ -> fail "tar entry not in a recognised format" + +correctChecksum :: ByteString -> Int -> Bool +correctChecksum header checksum = checksum == checksum' + where + -- sum of all 512 bytes in the header block, + -- treating each byte as an 8-bit unsigned value + checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' + -- treating the 8 bytes of chksum as blank characters. + header' = BS.concat [BS.take 148 header, + BS.Char8.replicate 8 ' ', + BS.drop 156 header] + +-- * TAR format primitive input + +getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a +getOct off len header + | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes)) + | null octstr = return 0 + | otherwise = case readOct octstr of + [(x,[])] -> return x + _ -> fail "tar header is malformed (bad numeric encoding)" + where + bytes = getBytes off len header + octstr = BS.Char8.unpack + . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') + . BS.Char8.dropWhile (== ' ') + $ bytes + + -- Some tar programs switch into a binary format when they try to represent + -- field values that will not fit in the required width when using the text + -- octal format. In particular, the UID/GID fields can only hold up to 2^21 + -- while in the binary format can hold up to 2^32. The binary format uses + -- '\128' as the header which leaves 7 bytes. Only the last 4 are used. + parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] = + return $! shiftL (fromIntegral byte3) 24 + + shiftL (fromIntegral byte2) 16 + + shiftL (fromIntegral byte1) 8 + + shiftL (fromIntegral byte0) 0 + parseBinInt _ = fail "tar header uses non-standard number encoding" + +getBytes :: Int64 -> Int64 -> ByteString -> ByteString +getBytes off len = BS.take len . BS.drop off + +getByte :: Int64 -> ByteString -> Char +getByte off bs = BS.Char8.index bs off + +getChars :: Int64 -> Int64 -> ByteString -> String +getChars off len = BS.Char8.unpack . getBytes off len + +getString :: Int64 -> Int64 -> ByteString -> String +getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len + +data Partial a = Error String | Ok a + +partial :: Partial a -> Either String a +partial (Error msg) = Left msg +partial (Ok x) = Right x + +instance Monad Partial where + return = Ok + Error m >>= _ = Error m + Ok x >>= k = k x + fail = Error + +-- +-- * Writing +-- + +-- | Create the external representation of a tar archive by serialising a list +-- of tar entries. +-- +-- * The conversion is done lazily. +-- +write :: [Entry] -> ByteString +write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] + +putEntry :: Entry -> ByteString +putEntry entry = case entryContent entry of + NormalFile content size -> BS.concat [ header, content, padding size ] + OtherEntryType _ content size -> BS.concat [ header, content, padding size ] + _ -> header + where + header = putHeader entry + padding size = BS.replicate paddingSize 0 + where paddingSize = fromIntegral (negate size `mod` 512) + +putHeader :: Entry -> ByteString +putHeader entry = + BS.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 { + entryTarPath = TarPath name prefix, + entryContent = content, + entryPermissions = permissions, + entryOwnership = ownership, + entryTime = modTime, + entryFormat = format + } = + + concat + [ putString 100 $ name + , putOct 8 $ permissions + , putOct 8 $ ownerId ownership + , putOct 8 $ groupId ownership + , putOct 12 $ contentSize + , putOct 12 $ modTime + , fill 8 $ ' ' -- dummy checksum + , putChar8 $ typeCode + , putString 100 $ linkTarget + ] ++ + case format of + V7Format -> + fill 255 '\NUL' + UstarFormat -> concat + [ putString 8 $ "ustar\NUL00" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putOct 8 $ deviceMajor + , putOct 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + GnuFormat -> concat + [ putString 8 $ "ustar \NUL" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putGnuDev 8 $ deviceMajor + , putGnuDev 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + where + (typeCode, contentSize, linkTarget, + deviceMajor, deviceMinor) = case content of + NormalFile _ size -> ('0' , size, [], 0, 0) + Directory -> ('5' , 0, [], 0, 0) + SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0) + HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0) + CharacterDevice major minor -> ('3' , 0, [], major, minor) + BlockDevice major minor -> ('4' , 0, [], major, minor) + NamedPipe -> ('6' , 0, [], 0, 0) + OtherEntryType code _ size -> (code, size, [], 0, 0) + + putGnuDev w n = case content of + CharacterDevice _ _ -> putOct w n + BlockDevice _ _ -> putOct w n + _ -> replicate w '\NUL' + +-- * TAR format primitive output + +type FieldWidth = Int + +putString :: FieldWidth -> String -> String +putString n s = take n s ++ fill (n - length s) '\NUL' + +--TODO: check integer widths, eg for large file sizes +putOct :: Integral a => FieldWidth -> a -> String +putOct n x = + let octStr = take (n-1) $ showOct x "" + in fill (n - length octStr - 1) '0' + ++ octStr + ++ putChar8 '\NUL' + +putChar8 :: Char -> String +putChar8 c = [c] + +fill :: FieldWidth -> Char -> String +fill n c = replicate n c + +-- +-- * Unpacking +-- + +unpack :: FilePath -> Entries -> IO () +unpack baseDir entries = unpackEntries [] (checkSecurity entries) + >>= emulateLinks + + where + -- We're relying here on 'checkSecurity' to make sure we're not scribbling + -- files all over the place. + + unpackEntries _ (Fail err) = fail err + unpackEntries links Done = return links + unpackEntries links (Next entry es) = case entryContent entry of + NormalFile file _ -> extractFile path file + >> unpackEntries links es + Directory -> extractDir path + >> unpackEntries links es + HardLink link -> (unpackEntries $! saveLink path link links) es + SymbolicLink link -> (unpackEntries $! saveLink path link links) es + _ -> unpackEntries links es --ignore other file types + where + path = entryPath entry + + extractFile path content = do + -- Note that tar archives do not make sure each directory is created + -- before files they contain, indeed we may have to create several + -- levels of directory. + createDirectoryIfMissing True absDir + BS.writeFile absPath content + where + absDir = baseDir FilePath.Native.takeDirectory path + absPath = baseDir path + + extractDir path = createDirectoryIfMissing True (baseDir path) + + saveLink path link links = seq (length path) + $ seq (length link') + $ (path, link'):links + where link' = fromLinkTarget link + + emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> + let absPath = baseDir relPath + absTarget = FilePath.Native.takeDirectory absPath relLinkTarget + in copyFile absTarget absPath + +-- +-- * Packing +-- + +pack :: FilePath -- ^ Base directory + -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + -> IO [Entry] +pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir + +preparePaths :: FilePath -> [FilePath] -> IO [FilePath] +preparePaths baseDir paths = + fmap concat $ interleave + [ do isDir <- doesDirectoryExist (baseDir path) + if isDir + then do entries <- getDirectoryContentsRecursive (baseDir path) + return (FilePath.Native.addTrailingPathSeparator path + : map (path ) entries) + else return [path] + | path <- paths ] + +packPaths :: FilePath -> [FilePath] -> IO [Entry] +packPaths baseDir paths = + interleave + [ do tarpath <- either fail return (toTarPath isDir relpath) + if isDir then packDirectoryEntry filepath tarpath + else packFileEntry filepath tarpath + | relpath <- paths + , let isDir = FilePath.Native.hasTrailingPathSeparator filepath + filepath = baseDir relpath ] + +interleave :: [IO a] -> IO [a] +interleave = unsafeInterleaveIO . go + where + go [] = return [] + go (x:xs) = do + x' <- x + xs' <- interleave xs + return (x':xs') + +packFileEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packFileEntry filepath tarpath = do + mtime <- getModTime filepath + perms <- getPermissions filepath + file <- openBinaryFile filepath ReadMode + size <- hFileSize file + content <- BS.hGetContents file + return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { + entryPermissions = if Permissions.executable perms + then executableFilePermissions + else ordinaryFilePermissions, + entryTime = mtime + } + +packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packDirectoryEntry filepath tarpath = do + mtime <- getModTime filepath + return (directoryEntry tarpath) { + entryTime = mtime + } + +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive dir0 = + fmap tail (recurseDirectories dir0 [""]) + +recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] +recurseDirectories _ [] = return [] +recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (base dir) + + files' <- recurseDirectories base (dirs' ++ dirs) + return (dir : 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 + dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry + isDirectory <- doesDirectoryExist (base dirEntry) + if isDirectory + then collect files (dirEntry':dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +getModTime :: FilePath -> IO EpochTime +getModTime path = do + (TOD s _) <- getModificationTime path + return $! fromIntegral s diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- 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 + ( PackageName, PackageId, Package(..) + , PackageFixedDeps(..), Dependency ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.PackageDescription + ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Version + ( VersionRange ) +import Distribution.Text + ( Text(disp,parse) ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + + +import Data.Char as Char +import Data.Map (Map) +import Network.URI (URI) +import Distribution.Compat.Exception + ( SomeException ) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data AvailablePackageDb = AvailablePackageDb { + packageIndex :: PackageIndex AvailablePackage, + packagePreferences :: Map PackageName VersionRange +} + +-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. +-- What is new in 1.8 is that installed packages and dependencies between +-- installed packages are now identified by an opaque InstalledPackageId +-- rather than a source PackageId. +-- +-- We should use simply an 'InstalledPackageInfo' here but to ease the +-- transition we are temporarily using this variant where we pretend that +-- installed packages still specify their deps in terms of PackageIds. +-- +-- Crucially this means that 'InstalledPackage' can be an instance of +-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance +-- of that class. This means we can make 'PackageIndex'es of InstalledPackage +-- where as the InstalledPackageInfo now has its own monomorphic index type. +-- +data InstalledPackage = InstalledPackage + InstalledPackageInfo + [PackageId] + +instance Package InstalledPackage where + packageId (InstalledPackage pkg _) = packageId pkg +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ deps) = deps + +-- | 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 + [PackageId] -- 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 :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: AvailablePackageSource + } + deriving Show + +instance Package AvailablePackage where packageId = packageInfoId + +data AvailablePackageSource = + + -- | An unpacked package in the given dir, or current dir + LocalUnpackedPackage (Maybe FilePath) + + -- | A package as a tarball that's available as a local tarball + | LocalTarballPackage FilePath + + -- | A package as a tarball from a remote URI + | RemoteTarballPackage URI + + -- | 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: +-- * 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,Eq) + + +instance Text UnresolvedDependency where + disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep) + where + dispFlags [] = Disp.empty + dispFlags fs = Disp.text "--flags=" + Disp.<> + (Disp.doubleQuotes $ flagAssToDoc fs) + flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> + (if not val then Disp.char '-' + else Disp.empty) + Disp.<> Disp.text fname + Disp.<+> flagAssDoc) + Disp.empty + parse = do + dep <- parse + Parse.skipSpaces + flagAss <- Parse.option [] parseFlagAssignment + return $ UnresolvedDependency dep flagAss + where + parseFlagAssignment :: Parse.ReadP r FlagAssignment + parseFlagAssignment = do + Parse.string "--flags" + Parse.skipSpaces + Parse.char '=' + Parse.skipSpaces + inDoubleQuotes $ Parse.many1 flag + where + inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a + inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') + + flag = do + Parse.skipSpaces + val <- negative Parse.+++ positive + name <- ident + Parse.skipSpaces + return (FlagName name,val) + negative = do + Parse.char '-' + return False + positive = return True + + ident :: Parse.ReadP r String + ident = do + -- First character must be a letter/digit to avoid flags + -- like "+-debug": + c <- Parse.satisfy Char.isAlphaNum + cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' + || ch == '-') + return (c:cs) + + + +type BuildResult = Either BuildFailure BuildSuccess +data BuildFailure = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | InstallFailed SomeException +data BuildSuccess = BuildOk DocsResult TestsResult + +data DocsResult = DocsNotTried | DocsFailed | DocsOk +data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Unpack +-- Copyright : (c) Andrea Vezzosi 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Unpack ( + + -- * Commands + unpack, + + ) where + +import Distribution.Package + ( PackageId, Dependency(..) ) +import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault) +import Distribution.Simple.Utils + ( notice, die ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text(display) + +import Distribution.Client.Setup(UnpackFlags(unpackVerbosity, + unpackDestDir)) +import Distribution.Client.Types(UnresolvedDependency(..), + Repo, AvailablePackageSource(..), + AvailablePackage(AvailablePackage), + AvailablePackageDb(AvailablePackageDb)) +import Distribution.Client.Dependency as Dependency + ( resolveAvailablePackages + , dependencyConstraints, dependencyTargets + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) ) +import Distribution.Client.Fetch + ( fetchPackage ) +import Distribution.Client.HttpUtils + ( downloadURI ) +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils as IndexUtils + (getAvailablePackages, disambiguateDependencies) + +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getTemporaryDirectory ) +import System.IO + ( openTempFile, hClose ) +import Control.Monad + ( unless, when ) +import Data.Monoid + ( mempty ) +import System.FilePath + ( (), addTrailingPathSeparator ) +import qualified Data.Map as Map + +unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO () +unpack flags _ [] = + notice verbosity "No packages requested. Nothing to do." + where + verbosity = fromFlag (unpackVerbosity flags) + +unpack flags repos deps = do + db@(AvailablePackageDb available _) + <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available + . map toUnresolved $ deps + + pkgs <- resolvePackages db deps' + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + flip mapM_ pkgs $ \pkg -> case pkg of + + AvailablePackage pkgid _ (LocalTarballPackage tarballPath) -> + unpackPackage verbosity prefix pkgid tarballPath + + AvailablePackage pkgid _ (RemoteTarballPackage tarballURL) -> do + tmp <- getTemporaryDirectory + (tarballPath, hnd) <- openTempFile tmp (display pkgid) + hClose hnd + --TODO: perhaps we've already had to download this to a local cache + -- so we even know what package version it is. So might be able + -- to get it from the local cache rather than from remote. + downloadURI verbosity tarballURL tarballPath + unpackPackage verbosity prefix pkgid tarballPath + + AvailablePackage pkgid _ (RepoTarballPackage repo) -> do + tarballPath <- fetchPackage verbosity repo pkgid + unpackPackage verbosity prefix pkgid tarballPath + + AvailablePackage _ _ (LocalUnpackedPackage _) -> + error "Distribution.Client.Unpack.unpack: the impossible happened." + + where + verbosity = fromFlag (unpackVerbosity flags) + prefix = fromFlagOrDefault "" (unpackDestDir flags) + toUnresolved d = UnresolvedDependency d [] + +unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () +unpackPackage verbosity prefix pkgid pkgPath = do + let pkgdirname = display pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + existsDir <- doesDirectoryExist pkgdir + when existsDir $ die $ + "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + +resolvePackages :: AvailablePackageDb + -> [UnresolvedDependency] + -> IO [AvailablePackage] +resolvePackages + (AvailablePackageDb available availablePrefs) deps = + + either (die . unlines . map show) return $ + resolveAvailablePackages + installed available + preferences constraints + targets + + where + installed = mempty + targets = dependencyTargets deps + constraints = dependencyConstraints deps + preferences = PackagesPreference + PreferLatestForSelected + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs @@ -0,0 +1,82 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..), AvailablePackageDb(..) ) +import Distribution.Client.Fetch + ( downloadIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.IndexUtils + ( getAvailablePackages ) +import qualified Paths_cabal_install + ( version ) + +import Distribution.Package + ( PackageName(..), packageVersion ) +import Distribution.Version + ( anyVersion, withinRange ) +import Distribution.Simple.Utils + ( warn, notice, writeFileAtomic ) +import Distribution.Verbosity + ( Verbosity ) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Distribution.Client.GZipUtils (maybeDecompress) +import qualified Data.Map as Map +import System.FilePath (dropExtension) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +-- | 'update' downloads the package list from all known servers +update :: Verbosity -> [Repo] -> IO () +update verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." +update verbosity repos = do + mapM_ (updateRepo verbosity) repos + checkForSelfUpgrade verbosity repos + +updateRepo :: Verbosity -> Repo -> IO () +updateRepo verbosity repo = case repoKind repo of + Right LocalRepo -> return () + Left remoteRepo -> do + notice verbosity $ "Downloading the latest package list from " + ++ remoteRepoName remoteRepo + indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) + writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack + . maybeDecompress + =<< BS.readFile indexPath + +checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () +checkForSelfUpgrade verbosity repos = do + AvailablePackageDb available prefs <- getAvailablePackages verbosity repos + + let self = PackageName "cabal-install" + preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) + currentVersion = Paths_cabal_install.version + laterPreferredVersions = + [ packageVersion pkg + | pkg <- PackageIndex.lookupPackageName available self + , let version = packageVersion pkg + , version > currentVersion + , version `withinRange` preferredVersionRange ] + + when (not (null laterPreferredVersions)) $ + notice verbosity $ + "Note: there is a new version of cabal-install available.\n" + ++ "To upgrade, run: cabal install cabal-install" + diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs @@ -0,0 +1,177 @@ +-- 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.TCP (HandleStream) +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, takeFileName) +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 + passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False -- no echoing for entering the password + fmap Password getLine + putStrLn "" + return passwd + +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 (HandleStream String) () + -> 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 contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> notice verbosity $ rspBody resp + _ -> debug verbosity $ rspBody resp + +mkRequest :: URI -> FilePath -> IO (Request String) +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=\""++takeFileName 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/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs @@ -0,0 +1,60 @@ +module Distribution.Client.Utils where + +import Data.List + ( sortBy, groupBy ) +import System.Directory + ( doesFileExist, getModificationTime + , getCurrentDirectory, setCurrentDirectory ) +import qualified Control.Exception as Exception + ( finally ) + +-- | 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 + +-- | 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) + +-- | Executes the action in the specified directory. +inDir :: Maybe FilePath -> IO () -> IO () +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# 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/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.World +-- Copyright : (c) Peter Robinson 2009 +-- License : BSD-like +-- +-- Maintainer : thaldyron@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Interface to the world-file that contains a list of explicitly +-- requested packages. Meant to be imported qualified. +-- +-- A world file entry stores the package-name, package-version, and +-- user flags. +-- For example, the entry generated by +-- # cabal install stm-io-hooks --flags="-debug" +-- looks like this: +-- # stm-io-hooks -any --flags="-debug" +-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) +-- use +-- # cabal install world +-- +----------------------------------------------------------------------------- +module Distribution.Client.World ( + insert, + delete, + getContents, + + worldPkg, + isWorldTarget, + isGoodWorldTarget, + ) where + +import Distribution.Simple.Utils( writeFileAtomic ) +import Distribution.Client.Types + ( UnresolvedDependency(..) ) +import Distribution.Package + ( PackageName(..), Dependency( Dependency ) ) +import Distribution.Version( anyVersion ) +import Distribution.Text( display, simpleParse ) +import Distribution.Verbosity ( Verbosity ) +import Distribution.Simple.Utils ( die, info, chattyTry ) +import Data.List( unionBy, deleteFirstsBy, nubBy ) +import Data.Maybe( isJust, fromJust ) +import System.IO.Error( isDoesNotExistError, ) +import qualified Data.ByteString.Lazy.Char8 as B +import Prelude hiding ( getContents ) + +-- | Adds packages to the world file; creates the file if it doesn't +-- exist yet. Version constraints and flag assignments for a package are +-- updated if already present. IO errors are non-fatal. +insert :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO () +insert = modifyWorld $ unionBy equalUDep + +-- | Removes packages from the world file. +-- Note: Currently unused as there is no mechanism in Cabal (yet) to +-- handle uninstalls. IO errors are non-fatal. +delete :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO () +delete = modifyWorld $ flip (deleteFirstsBy equalUDep) + +-- | UnresolvedDependency values are considered equal if they refer to +-- the same package, i.e., we don't care about differing versions or flags. +equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool +equalUDep (UnresolvedDependency (Dependency pkg1 _) _) + (UnresolvedDependency (Dependency pkg2 _) _) = pkg1 == pkg2 + +-- | Modifies the world file by applying an update-function ('unionBy' +-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of +-- packages. IO errors are considered non-fatal. +modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency] + -> [UnresolvedDependency]) + -- ^ Function that defines how + -- the list of user packages are merged with + -- existing world packages. + -> Verbosity + -> FilePath -- ^ Location of the world file + -> [UnresolvedDependency] -- ^ list of user supplied packages + -> IO () +modifyWorld _ _ _ [] = return () +modifyWorld f verbosity world pkgs = + chattyTry "Error while updating world-file. " $ do + pkgsOldWorld <- getContents world + -- Filter out packages that are not in the world file: + let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld + -- 'Dependency' is not an Ord instance, so we need to check for + -- equivalence the awkward way: + if not (all (`elem` pkgsOldWorld) pkgsNewWorld && + all (`elem` pkgsNewWorld) pkgsOldWorld) + then do + info verbosity "Updating world file..." + writeFileAtomic world $ unlines + [ (display pkg) | pkg <- pkgsNewWorld] + else + info verbosity "World file is already up to date." + + +-- | Returns the content of the world file as a list +getContents :: FilePath -> IO [UnresolvedDependency] +getContents world = do + content <- safelyReadFile world + let result = map simpleParse (lines $ B.unpack content) + if all isJust result + then return $ map fromJust result + else die "Could not parse world file." + where + safelyReadFile :: FilePath -> IO B.ByteString + safelyReadFile file = B.readFile file `catch` handler + where + handler e | isDoesNotExistError e = return B.empty + | otherwise = ioError e + + +-- | A dummy package that represents the world file. +worldPkg :: PackageName +worldPkg = PackageName "world" + +-- | Currently we have a silly way of representing the world target as +-- an 'UnresolvedDependency' so we need a way to recognise it. +-- +-- We should be using a structured type with various target kinds, like +-- local file, repo package etc. +-- +isWorldTarget :: UnresolvedDependency -> Bool +isWorldTarget (UnresolvedDependency (Dependency pkg _) _) = + pkg == worldPkg + +isGoodWorldTarget :: UnresolvedDependency -> Bool +isGoodWorldTarget (UnresolvedDependency (Dependency pkg ver) flags) = + pkg == worldPkg + && ver == anyVersion + && null flags diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs b/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.Exception ( + SomeException, + onException, + catchIO, + handleIO, + catchExit, + throwIOIO + ) where + +import System.Exit +import qualified Control.Exception as Exception +#if MIN_VERSION_base(4,0,0) +import Control.Exception (SomeException) +#else +import Control.Exception (Exception) +type SomeException = Exception +#endif + +onException :: IO a -> IO b -> IO a +#if MIN_VERSION_base(4,0,0) +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#if MIN_VERSION_base(4,0,0) +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif diff --git a/cabal-install-0.9.5_rc20101226/LICENSE b/cabal-install-0.9.5_rc20101226/LICENSE new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, + Lemmih, Paolo Martini, Don Stewart, + Duncan Coutts +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal-install-0.9.5_rc20101226/Main.hs b/cabal-install-0.9.5_rc20101226/Main.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Main.hs @@ -0,0 +1,388 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +----------------------------------------------------------------------------- + +module Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, globalRepos + , ConfigFlags(..) + , ConfigExFlags(..), configureExCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand + , FetchFlags(..), fetchCommand + , checkCommand + , updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , InitFlags, initCommand + , reportCommand + , unpackCommand, UnpackFlags(..) + , parsePackageArgs ) +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.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile ) +import Distribution.Client.List (list, info) +import Distribution.Client.Install (install, upgrade) +import Distribution.Client.Configure (configure) +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 Distribution.Client.Unpack (unpack) +import Distribution.Client.Init (initCabal) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade + +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Simple.Command +import Distribution.Simple.Configure (configCompilerAux) +import Distribution.Simple.Utils + ( cabalVersion, die, topHandler, intercalate ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal, intToVerbosity ) +import qualified Paths_cabal_install (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +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) + +-- | Entry point +-- +main :: IO () +main = getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args +mainWorker args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalflags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalflags + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + printOptionsList = putStr . unlines + printErrors errs = die $ concat (intersperse "\n" errs) + printNumericVersion = putStrLn $ display Paths_cabal_install.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ "\nusing version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = + [installCommand `commandAddAction` installAction + ,updateCommand `commandAddAction` updateAction + ,listCommand `commandAddAction` listAction + ,infoCommand `commandAddAction` infoAction + ,fetchCommand `commandAddAction` fetchAction + ,unpackCommand `commandAddAction` unpackAction + ,checkCommand `commandAddAction` checkAction + ,sdistCommand `commandAddAction` sdistAction + ,uploadCommand `commandAddAction` uploadAction + ,reportCommand `commandAddAction` reportAction + ,initCommand `commandAddAction` initAction + ,configureExCommand `commandAddAction` configureAction + ,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 + ,upgradeCommand `commandAddAction` upgradeAction + ] + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command (GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + setupScriptOptions = defaultSetupScriptOptions { + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (distPrefFlag flags) + } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> GlobalFlags -> IO () +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags' + configure verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf configFlags' configExFlags' extraArgs + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +installAction (configFlags, _, installFlags) _ _globalFlags + | fromFlagOrDefault False (installOnly installFlags) + = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + in setupWrapper verbosity defaultSetupScriptOptions Nothing + installCommand (const mempty) [] + +installAction (configFlags, configExFlags, installFlags) + extraArgs globalFlags = do + pkgs <- either die return (parsePackageArgs extraArgs) + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags' + install verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf globalFlags' configFlags' configExFlags' installFlags' + [ UnresolvedDependency pkg (configConfigurationsFlags configFlags') + | pkg <- pkgs ] + +listAction :: ListFlags -> [String] -> GlobalFlags -> IO () +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags + list verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () +infoAction infoFlags extraArgs globalFlags = do + pkgs <- either die return (parsePackageArgs extraArgs) + let verbosity = fromFlag (infoVerbosity infoFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags + info verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + infoFlags + [ UnresolvedDependency pkg [] | pkg <- pkgs ] + +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 + let verbosity = fromFlag verbosityFlag + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + update verbosity (globalRepos globalFlags') + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +upgradeAction (configFlags, configExFlags, installFlags) + extraArgs globalFlags = do + pkgs <- either die return (parsePackageArgs extraArgs) + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags' + upgrade verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf globalFlags' configFlags' configExFlags' installFlags' + [ UnresolvedDependency pkg (configConfigurationsFlags configFlags') + | pkg <- pkgs ] + +fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () +fetchAction fetchFlags extraArgs globalFlags = do + pkgs <- either die return (parsePackageArgs extraArgs) + let verbosity = fromFlag (fetchVerbosity fetchFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags + fetch verbosity + (configPackageDB' configFlags) (globalRepos globalFlags') + comp conf fetchFlags + [ UnresolvedDependency pkg [] --TODO: flags? + | pkg <- pkgs ] + +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 + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + checkTarFiles extraArgs + if fromFlag (uploadCheck uploadFlags') + then Upload.check verbosity tarfiles + else upload verbosity + (globalRepos globalFlags') + (flagToMaybe $ uploadUsername uploadFlags') + (flagToMaybe $ uploadPassword uploadFlags') + tarfiles + where + checkTarFiles tarfiles + | null tarfiles + = die "the 'upload' command expects one or more .tar.gz packages." + | not (null otherFiles) + = die $ "the 'upload' command expects only .tar.gz packages: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + +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] -> 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 + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + + Upload.report verbosity (globalRepos globalFlags') + +unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () +unpackAction flags extraArgs globalFlags = do + pkgs <- either die return (parsePackageArgs extraArgs) + let verbosity = fromFlag (unpackVerbosity flags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + unpack flags (globalRepos (savedGlobalFlags config)) pkgs + +initAction :: InitFlags -> [String] -> GlobalFlags -> IO () +initAction flags _extraArgs _globalFlags = do + initCabal flags + +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +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 () + +-- +-- Utils (transitionary) +-- + +-- | Currently the user interface specifies the package dbs to use with just a +-- single valued option, a 'PackageDB'. However internally we represent the +-- stack of 'PackageDB's explictly as a list. This function converts encodes +-- the package db stack implicit in a single packagedb. +-- +-- TODO: sort this out, make it consistent with the command line UI +implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack +implicitPackageDbStack userInstall packageDbFlag + | userInstall = GlobalPackageDB : UserPackageDB : extra + | otherwise = GlobalPackageDB : extra + where + extra = case packageDbFlag of + Just (SpecificPackageDB db) -> [SpecificPackageDB db] + _ -> [] + +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) + where + userInstall = fromFlagOrDefault True (configUserInstall cfg) diff --git a/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs b/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs @@ -0,0 +1,8 @@ +module Paths_cabal_install ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,9,5], versionTags = []} diff --git a/cabal-install-0.9.5_rc20101226/README b/cabal-install-0.9.5_rc20101226/README new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/README @@ -0,0 +1,153 @@ +The cabal-install package +========================= + +[Cabal home page](http://www.haskell.org/cabal/) + +The `cabal-install` package provides a command line tool called `cabal`. The +tool uses the `Cabal` library and provides a convenient user interface to the +Cabal/Hackage package build and distribution system. It can build and install +both local and remote packages, including dependencies. + + +Installation instructions for the cabal-install command line tool +================================================================= + +The `cabal-install` package requires a number of other packages, most of which +come with a standard ghc installation. It requires the `network` package, which +is sometimes packaged separately by Linux distributions, for example on +debian or ubuntu it is in "libghc6-network-dev". + +It requires a few other Haskell packages that are not always installed: + + * Cabal (version 1.8 or later) + * HTTP (version 4000 or later) + * zlib (version 0.4 or later) + +All of these are available from [Hackage](http://hackage.haskell.org). + +Note that on some Unix systems you may need to install an additional zlib +development package using your system package manager, for example on +debian or ubuntu it is in "zlib1g-dev". It is needed is because the +Haskell zlib package uses the system zlib C library and header files. + +The `cabal-install` package is now part of the Haskell Platform so you do not +usually need to install it separately. However if you are starting from a +minimal ghc installation then you need to install `cabal-install` manually. +Since it is just an ordinary Cabal package it can be built in the standard +way, but to make it a bit easier we have partly automated the process: + + +Quickstart on Unix systems +-------------------------- + +As a convenience for users on Unix systems there is a `bootstrap.sh` script +which will download and install each of the dependencies in turn. + + $ ./bootstrap.sh + +It will download and install the above three dependencies. The script will +install the library packages into `$HOME/.cabal/` and the `cabal` program will +be installed into `$HOME/.cabal/bin/`. + +You then have two choices: + + * put `$HOME/.cabal/bin` on your `$PATH` + * move the `cabal` program somewhere that is on your `$PATH` + +The next thing to do is to get the latest list of packages with: + + $ cabal update + +This will also create a default config file (if it does not already echo exist) +at `$HOME/.cabal/config` + +By default cabal will install programs to `$HOME/.cabal/bin`. If you do not +want to add this directory to your `$PATH` then you can change the setting in +the config file, for example you could use: + + symlink-bindir: $HOME/bin + + +Quickstart on Windows systems +----------------------------- + +For Windows users we provide a pre-compiled [cabal.exe] program. Just download +it and put it somewhere on your `%PATH%`, for example +`C:\Program Files\Haskell\bin`. + +[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe + +The next thing to do is to get the latest list of packages with + + cabal update + +This will also create a default config file (if it does not already echo exist) +at `C:\Documents and Settings\username\Application Data\cabal\config` + + +Using cabal-install +=================== + +There are two sets of commands: commands for working with a local project build +tree and ones for working with distributed released packages from hackage. + +For a list of the full set of commands and the flags for each command see + + $ cabal --help + + +Commands for developers for local build trees +--------------------------------------------- + +The commands for local project build trees are almost exactly the same as the +`runghc Setup` command line interface that many people are already familiar +with. In particular there are the commands + + cabal configure + cabal build + cabal haddock + cabal clean + cabal sdist + +The `install` command is somewhat different. It is an all-in-one operation. If +you run + + $ cabal install + +in your build tree it will configure, build and install. It takes all the flags +that `configure` takes such as `--global` and `--prefix`. + +In addition, if any dependencies are not installed it will download and install +them. If can also rebuild packages to ensure a consistent set of dependencies. + + +Commands for released hackage packages +-------------------------------------- + + $ cabal update + +This command gets the latest list of packages from the hackage server. +Currently this command has to be run manually occasionally, in particular if +you want to install a newly released package. + + + $ cabal install xmonad + +This is the eponymous command. It installs one or more named packages (and all +their dependencies) from hackage. + +By default it installs the latest available version however you can optionally +specify exact versions or version ranges. For example `cabal install alex-2.2` +or `cabal install parsec < 3`. + + $ cabal upgrade xmonad + +This is a variation on the `install` command. Both mean to install the latest +version, the only difference is in the treatment of dependencies. The `install` +command tries to use existing installed versions of dependent packages while +the `upgrade` command tries to upgrade all the dependencies too. + + $ cabal list xml + +This does a search of the installed and available packages. It does a +case-insensitive substring match on the package name. diff --git a/cabal-install-0.9.5_rc20101226/Setup.hs b/cabal-install-0.9.5_rc20101226/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-install-0.9.5_rc20101226/bash-completion/cabal b/cabal-install-0.9.5_rc20101226/bash-completion/cabal new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/bash-completion/cabal @@ -0,0 +1,24 @@ +# cabal command line completion +# Copyright 2007-2008 "Lennart Kolmodin" +# "Duncan Coutts" +# + +_cabal() +{ + # get the word currently being completed + local cur + cur=${COMP_WORDS[$COMP_CWORD]} + + # create a command line to run + local cmd + # copy all words the user has entered + cmd=( ${COMP_WORDS[@]} ) + + # replace the current word with --list-options + cmd[${COMP_CWORD}]="--list-options" + + # the resulting completions should be put into this array + COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) ) +} + +complete -F _cabal -o default cabal diff --git a/cabal-install-0.9.5_rc20101226/bootstrap.sh b/cabal-install-0.9.5_rc20101226/bootstrap.sh new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/bootstrap.sh @@ -0,0 +1,241 @@ +#!/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. + +# install settings, you can override these by setting environment vars +PREFIX=${PREFIX:-${HOME}/.cabal} +#VERBOSE +#EXTRA_CONFIGURE_OPTS + +# programs, you can override these by setting environment vars +GHC=${GHC:-ghc} +GHC_PKG=${GHC_PKG:-ghc-pkg} +WGET=${WGET:-wget} +CURL=${CURL:-curl} +TAR=${TAR:-tar} +GUNZIP=${GUNZIP:-gunzip} +SCOPE_OF_INSTALLATION="--user" + + +for arg in $* +do + case "${arg}" in + "--user") + SCOPE_OF_INSTALLATION=${arg} + shift;; + "--global") + SCOPE_OF_INSTALLATION=${arg} + PREFIX="/usr/local" + shift;; + *) + echo "Unknown argument or option, quitting: ${arg}" + echo "usage: bootstrap.sh [OPTION]" + echo + echo "options:" + echo " --user Install for the local user (default)" + echo " --global Install systemwide" + exit;; + esac +done + + +# Versions of the packages to install. +# The version regex says what existing installed versions are ok. +PARSEC_VER="2.1.0.1"; PARSEC_VER_REGEXP="2\." # == 2.* +NETWORK_VER="2.2.1.10"; NETWORK_VER_REGEXP="2\." # == 2.* +CABAL_VER="1.10.0.0"; CABAL_VER_REGEXP="1\.10\." # == 1.10.* +MTL_VER="1.1.1.0"; MTL_VER_REGEXP="1\.1\." # == 1.1.* +HTTP_VER="4000.0.10"; HTTP_VER_REGEXP="4000\.0" # == 4000.0.* +ZLIB_VER="0.5.2.0"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.* +TIME_VER="1.2.0.3" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* + +HACKAGE_URL="http://hackage.haskell.org/packages/archive" + +die () { + echo + echo "Error during cabal-install bootstrap:" + echo $1 >&2 + exit 2 +} + +# Check we're in the right directory: +grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \ + || die "The bootstrap.sh script must be run in the cabal-install directory" + +${GHC} --numeric-version > /dev/null \ + || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars." +${GHC_PKG} --version > /dev/null \ + || die "${GHC_PKG} not found." +GHC_VER=`${GHC} --numeric-version` +GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5` +[ ${GHC_VER} = ${GHC_PKG_VER} ] \ + || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too" + +# Cache the list of packages: +echo "Checking installed packages for ghc-${GHC_VER}..." +${GHC_PKG} list > ghc-pkg.list \ + || die "running '${GHC_PKG} list' failed" + +# Will we need to install this package, or is a suitable version installed? +need_pkg () { + PKG=$1 + VER_MATCH=$2 + if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 + then + return 1; + else + return 0; + fi + #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. +} + +info_pkg () { + PKG=$1 + VER=$2 + VER_MATCH=$3 + + if need_pkg ${PKG} ${VER_MATCH} + then + echo "${PKG}-${VER} will be downloaded and installed." + else + echo "${PKG} is already installed and the version is ok." + fi +} + +dep_pkg () { + PKG=$1 + VER_MATCH=$2 + if need_pkg ${PKG} ${VER_MATCH} + then + echo + echo "The Haskell package '${PKG}' is required but it is not installed." + echo "If you are using a ghc package provided by your operating system" + echo "then install the corresponding packages for 'parsec' and 'network'." + echo "If you built ghc from source with only the core libraries then you" + echo "should install these extra packages. You can get them from hackage." + die "The Haskell package '${PKG}' is required but it is not installed." + else + echo "${PKG} is already installed and the version is ok." + fi +} + +fetch_pkg () { + PKG=$1 + VER=$2 + + URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz + if which ${CURL} > /dev/null + then + ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}." + elif which ${WGET} > /dev/null + then + ${WGET} -c ${URL} || die "Failed to download ${PKG}." + else + die "Failed to find a downloader. 'wget' or 'curl' is required." + fi + [ -f "${PKG}-${VER}.tar.gz" ] \ + || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz" +} + +unpack_pkg () { + PKG=$1 + VER=$2 + + rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/ + ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \ + || die "Failed to gunzip ${PKG}-${VER}.tar.gz" + ${TAR} -xf "${PKG}-${VER}.tar" \ + || die "Failed to untar ${PKG}-${VER}.tar.gz" + [ -d "${PKG}-${VER}" ] \ + || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/" +} + +install_pkg () { + PKG=$1 + + [ -x Setup ] && ./Setup clean + [ -f Setup ] && rm Setup + + ${GHC} --make Setup -o Setup \ + || die "Compiling the Setup script failed" + [ -x Setup ] || die "The Setup script does not exist or cannot be run" + + ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \ + --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \ + ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \ + || die "Configuring the ${PKG} package failed" + + ./Setup build ${VERBOSE} \ + || die "Building the ${PKG} package failed" + + ./Setup install ${VERBOSE} \ + || die "Installing the ${PKG} package failed" +} + +do_pkg () { + PKG=$1 + VER=$2 + VER_MATCH=$3 + + if need_pkg ${PKG} ${VER_MATCH} + then + echo + echo "Downloading ${PKG}-${VER}..." + fetch_pkg ${PKG} ${VER} + unpack_pkg ${PKG} ${VER} + cd "${PKG}-${VER}" + install_pkg ${PKG} ${VER} + cd .. + fi +} + +# Actually do something! + +info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} +info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} +info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} +info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} +info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} +info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} + +do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} +do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} +do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} +do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} +do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} +do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} + +install_pkg "cabal-install" + +echo +echo "===========================================" +CABAL_BIN="$PREFIX/bin" +if [ -x "$CABAL_BIN/cabal" ] +then + echo "The 'cabal' program has been installed in $CABAL_BIN/" + echo "You should either add $CABAL_BIN to your PATH" + echo "or copy the cabal program to a directory that is on your PATH." + echo + echo "The first thing to do is to get the latest list of packages with:" + echo " cabal update" + echo "This will also create a default config file (if it does not already" + echo "exist) at $HOME/.cabal/config" + echo + echo "By default cabal will install programs to $HOME/.cabal/bin" + echo "If you do not want to add this directory to your PATH then you can" + echo "change the setting in the config file, for example you could use:" + echo "symlink-bindir: $HOME/bin" +else + echo "Sorry, something went wrong." + echo "The 'cabal' executable was not successfully installed into" + echo "$CABAL_BIN/" +fi +echo + +rm ghc-pkg.list diff --git a/cabal-install-0.9.5_rc20101226/cabal-install.cabal b/cabal-install-0.9.5_rc20101226/cabal-install.cabal new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/cabal-install.cabal @@ -0,0 +1,117 @@ +Name: cabal-install +Version: 0.9.5 +Synopsis: The command-line interface for Cabal and Hackage. +Description: + The \'cabal\' command-line program simplifies the process of managing + Haskell software by automating the fetching, configuration, compilation + and installation of Haskell libraries and programs. +homepage: http://www.haskell.org/cabal/ +bug-reports: http://hackage.haskell.org/trac/hackage/ +License: BSD3 +License-File: LICENSE +Author: Lemmih + Paolo Martini + 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 + 2007-2010 Duncan Coutts +Category: Distribution +Build-type: Simple +Extra-Source-Files: README bash-completion/cabal bootstrap.sh +Cabal-Version: >= 1.6 + +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal-install/ + +flag old-base + description: Old, monolithic base + default: False + +flag bytestring-in-base + +Executable cabal + Main-Is: Main.hs + -- We want assertion checking on even if people build with -O + -- although it is expensive, we want to catch problems early: + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + Other-Modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.TopDown + Distribution.Client.Dependency.TopDown.Constraints + Distribution.Client.Dependency.TopDown.Types + Distribution.Client.Dependency.Types + Distribution.Client.Fetch + Distribution.Client.GZipUtils + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.List + Distribution.Client.PackageIndex + Distribution.Client.PackageUtils + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SrcDist + Distribution.Client.Tar + Distribution.Client.Types + Distribution.Client.Unpack + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.World + Distribution.Client.Win32SelfUpgrade + Distribution.Compat.Exception + Paths_cabal_install + + build-depends: base >= 2 && < 5, + Cabal >= 1.10 && < 1.11, + filepath >= 1.0 && < 1.3, + network >= 1 && < 3, + HTTP >= 4000.0.2 && < 4001, + zlib >= 0.4 && < 0.6, + time >= 1.1 && < 1.3 + + if flag(old-base) + build-depends: base < 3 + else + build-depends: base >= 3, + process >= 1 && < 1.1, + directory >= 1 && < 1.2, + pretty >= 1 && < 1.1, + random >= 1 && < 1.1, + containers >= 0.1 && < 0.5, + array >= 0.1 && < 0.4, + old-time >= 1 && < 1.1 + + if flag(bytestring-in-base) + build-depends: base >= 2.0 && < 2.2 + else + build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + cpp-options: -DWIN32 + else + build-depends: unix >= 1.0 && < 2.5 + extensions: CPP diff --git a/cabal-install-0.9.5_rc20101226/changelog b/cabal-install-0.9.5_rc20101226/changelog new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/changelog @@ -0,0 +1,100 @@ +-*-change-log-*- + +0.8.0 Duncan Coutts Dec 2009 + * Works with ghc-6.12 + * New "cabal init" command for making initial project .cabal file + * New feature to maintain an index of haddock documentation + +0.6.4 Duncan Coutts Nov 2009 + * Improve the algorithm for selecting the base package version + * Hackage errors now reported by "cabal upload [--check]" + * Improved format of messages from "cabal check" + * Config file can now be selected by an env var + * Updated tar reading/writing code + * Improve instructions in the README and bootstrap output + * Fix bootstrap.sh on Solaris 9 + * Fix bootstrap for systems where network uses parsec 3 + * Fix building with ghc-6.6 + +0.6.2 Duncan Coutts Feb 2009 + * The upgrade command has been disabled in this release + * The configure and install commands now have consistent behaviour + * Reduce the tendancy to re-install already existing packages + * The --constraint= flag now works for the install command + * New --preference= flag for soft constraints / version preferences + * Improved bootstrap.sh script, smarter and better error checking + * New cabal info command to display detailed info on packages + * New cabal unpack command to download and untar a package + * HTTP-4000 package required, should fix bugs with http proxies + * Now works with authenticated proxies. + * On Windows can now override the proxy setting using an env var + * Fix compatability with config files generated by older versions + * Warn if the hackage package list is very old + * More helpful --help output, mention config file and examples + * Better documentation in ~/.cabal/config file + * Improved command line interface for logging and build reporting + * Minor improvements to some messages + +0.6.0 Duncan Coutts Oct 2008 + * Constraint solver can now cope with base 3 and base 4 + * Allow use of package version preferences from hackage index + * More detailed output from cabal install --dry-run -v + * Improved bootstrap.sh + +0.5.2 Duncan Coutts Aug 2008 + * Suport building haddock documentaion + * Self-reinstall now works on Windows + * Allow adding symlinks to excutables into a separate bindir + * New self-documenting config file + * New install --reinstall flag + * More helpful status messages in a couple places + * Upload failures now report full text error message from the server + * Support for local package repositories + * New build logging and reporting + * New command to upload build reports to (a compatible) server + * Allow tilde in hackage server URIs + * Internal code improvements + * Many other minor improvements and bug fixes + +0.5.1 Duncan Coutts June 2008 + * Restore minimal hugs support in dependency resolver + * Fix for disabled http proxies on Windows + * Revert to global installs on Windows by default + +0.5.0 Duncan Coutts June 2008 + * New package dependency resolver, solving diamond dep problem + * Integrate cabal-setup functionality + * Integrate cabal-upload functionality + * New cabal update and check commands + * Improved behavior for install and upgrade commands + * Full Windows support + * New command line handling + * Bash command line completion + * Allow case insensitive package names on command line + * New --dry-run flag for install, upgrade and fetch commands + * New --root-cmd flag to allow installing as root + * New --cabal-lib-version flag to select different Cabal lib versions + * Support for HTTP proxies + * Improved cabal list output + * Build other non-dependent packages even when some fail + * Report a summary of all build failures at the end + * Partial support for hugs + * Partial implementation of build reporting and logging + * More consistent logging and verbosity + * Significant internal code restructuring + +0.4 Duncan Coutts Oct 2007 + * Renamed executable from 'cabal-install' to 'cabal' + * Partial Windows compatability + * Do per-user installs by default + * cabal install now installs the package in the current directory + * Allow multiple remote servers + * Use zlib lib and internal tar code and rather than external tar + * Reorganised configuration files + * Significant code restructuring + * Cope with packages with conditional dependencies + +0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007 + * Switch from smart-server, dumb-client model to the reverse + * New .tar.gz based index format + * New remote and local package archive format diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install @@ -0,0 +1,9 @@ +#!/bin/sh + +darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ +cd Cabal/cabal-install && \ +make && \ +sudo make install && \ +sudo cabal-install update && \ +cabal-install install --prefix=/tmp --user hnop && \ +ls -l /tmp/bin/hnop diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user new file mode 100644 --- /dev/null +++ b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user @@ -0,0 +1,8 @@ +#!/bin/sh + +darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ +cd Cabal/cabal-install && \ +make install-user && \ +cabal-install update && \ +cabal-install install --prefix=/tmp --user hnop && \ +ls -l /tmp/bin/hnop diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,5 +1,5 @@ Name: hackport -Version: 0.2.9 +Version: 0.2.10 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin @@ -9,7 +9,7 @@ Description: A command line tool to manage an overlay of Gentoo ebuilds that are generated from a hackage repo of Cabal packages. Build-Type: Simple -Cabal-Version: >=1.8 +Cabal-Version: >=1.10 source-repository head type: darcs @@ -19,7 +19,8 @@ Executable hackport Main-Is: Main.hs - Hs-Source-Dirs: ., cabal-install-0.8.2 + Default-Language: Haskell98 + Hs-Source-Dirs: ., cabal-install-0.9.5_rc20101226 Build-Depends: base >= 2.0 && < 5, filepath, @@ -28,15 +29,27 @@ network, pretty, regex-compat, - Cabal == 1.8.*, + Cabal == 1.10.*, HTTP >= 4000.0.3, zlib, tar, + xml>1.3.5, array, -- array is inherited from cabal-install -- tar >= 0.3.0.0 && < 0.4 extensible-exceptions + -- extensions due to hackport + other-extensions: + DeriveDataTypeable, + PatternGuards + + -- extensions due to bundled cabal-install + other-extensions: + CPP, + ForeignFunctionInterface, + PatternGuards + if flag(split-base) Build-Depends: base >= 3 && < 5, @@ -58,12 +71,11 @@ Error Paths_hackport Main - MaybeRead Overlays - P2 Portage Portage.Version Portage.Dependency + Portage.GHCCore Portage.PackageId Portage.Overlay Portage.Resolve @@ -73,3 +85,42 @@ Status Merge Util + + +Executable hackport-guess-ghc-version + Main-Is: Main-GuessGHC.hs + Default-Language: Haskell98 + Buildable: False + -- this was used as a test while developing the + -- ghc-guessfeature. now we can disable building + Build-Depends: + base >= 2.0 && < 5, + filepath, + parsec, + mtl, + network, + pretty, + regex-compat, + Cabal > 1.8 && < 1.11, + HTTP >= 4000.0.3, + zlib, + tar, + array, + -- array is inherited from cabal-install + -- tar >= 0.3.0.0 && < 0.4 + extensible-exceptions + + if flag(split-base) + Build-Depends: + base >= 3 && < 5, + directory, + containers, + process, + old-time, + bytestring + else + Build-Depends: base < 3 + + ghc-options: -Wall + other-modules: + Portage.GHCCore