cabal-install (empty) → 0.4.0
raw patch · 18 files changed
+1727/−0 lines, 18 filesdep +Cabaldep +HTTPdep +basesetup-changed
Dependencies added: Cabal, HTTP, base, bytestring, directory, filepath, network, pretty, process, zlib
Files
- Hackage/Clean.hs +29/−0
- Hackage/Config.hs +255/−0
- Hackage/Dependency.hs +157/−0
- Hackage/Fetch.hs +135/−0
- Hackage/Index.hs +64/−0
- Hackage/Info.hs +64/−0
- Hackage/Install.hs +168/−0
- Hackage/List.hs +64/−0
- Hackage/Setup.hs +204/−0
- Hackage/Tar.hs +162/−0
- Hackage/Types.hs +94/−0
- Hackage/Update.hs +35/−0
- Hackage/Utils.hs +98/−0
- LICENSE +33/−0
- Main.hs +60/−0
- README +47/−0
- Setup.lhs +3/−0
- cabal-install.cabal +55/−0
+ Hackage/Clean.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Clean+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- +-----------------------------------------------------------------------------+module Hackage.Clean+ ( clean+ ) where++import Hackage.Types (ConfigFlags(..))+import Hackage.Utils (fileNotFoundExceptions)++import System.Directory (removeDirectoryRecursive)+import Control.Exception (catchJust)++-- | 'clean' removes all downloaded packages from the {config-dir}\/packages\/ directory.+clean :: ConfigFlags -> IO ()+clean cfg+ = catchJust fileNotFoundExceptions+ (removeDirectoryRecursive (configCacheDir cfg))+ -- The packages dir may not exist if it's already cleaned:+ (const (return ()))
+ Hackage/Config.hs view
@@ -0,0 +1,255 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Config+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Utilities for handling saved state such as known packages, known servers and downloaded packages.+-----------------------------------------------------------------------------+module Hackage.Config+ ( repoCacheDir+ , packageFile+ , packageDir+ , listInstalledPackages+ , message+ , pkgURL+ , defaultConfigFile+ , loadConfig+ , showConfig+ , findCompiler+ ) where++import Prelude hiding (catch)+import Control.Monad (when)+import Data.Char (isAlphaNum, toLower)+import Data.List (intersperse)+import Data.Maybe (fromMaybe)+import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory)+import System.FilePath ((</>), takeDirectory, (<.>))+import System.IO (hPutStrLn, stderr)+import Text.PrettyPrint.HughesPJ (text)++import Distribution.Compat.ReadP (ReadP, char, munch1, readS_to_P)+import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)+import Distribution.Package (PackageIdentifier(..), showPackageId)+import Distribution.PackageDescription (ParseResult(..))+import Distribution.ParseUtils (FieldDescr(..), simpleField, listField, liftField, field)+import Distribution.Simple.Compiler (Compiler, PackageDB(..))+import Distribution.Simple.Configure (getInstalledPackages)+import qualified Distribution.Simple.Configure as Configure (configCompiler)+import Distribution.Simple.InstallDirs (InstallDirTemplates(..), PathTemplate, toPathTemplate, defaultInstallDirs)+import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)+import Distribution.Version (showVersion)+import Distribution.Verbosity (Verbosity, normal)++import Hackage.Types (ConfigFlags (..), PkgInfo (..), Repo(..))+import Hackage.Utils+++-- | Full path to the local cache directory for a repository.+repoCacheDir :: ConfigFlags -> Repo -> FilePath+repoCacheDir cfg repo = configCacheDir cfg </> repoName repo++-- |Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+packageFile :: ConfigFlags -> PkgInfo -> FilePath+packageFile cfg pkg = packageDir cfg pkg+ </> showPackageId (pkgInfoId pkg)+ <.> "tar.gz"++-- |Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+packageDir :: ConfigFlags -> PkgInfo -> FilePath+packageDir cfg pkg = repoCacheDir cfg (pkgRepo pkg)+ </> pkgName p+ </> showVersion (pkgVersion p)+ where p = pkgInfoId pkg++listInstalledPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> IO [PackageIdentifier]+listInstalledPackages cfg comp conf =+ do Just ipkgs <- getInstalledPackages+ (configVerbose cfg) comp+ (if configUserInstall cfg then UserPackageDB+ else GlobalPackageDB)+ conf+ return ipkgs++message :: ConfigFlags -> Verbosity -> String -> IO ()+message cfg v s = when (configVerbose cfg >= v) (putStrLn s)++-- | Generate the URL of the tarball for a given package.+pkgURL :: PkgInfo -> String+pkgURL pkg = joinWith "/" [repoURL (pkgRepo pkg), pkgName p, showVersion (pkgVersion p), + showPackageId p ++ ".tar.gz"] + where joinWith tok = concat . intersperse tok+ p = pkgInfoId pkg++--+-- * Compiler and programs+--++findCompiler :: ConfigFlags -> IO (Compiler, ProgramConfiguration)+findCompiler cfg = Configure.configCompiler + (Just (configCompiler cfg)) + (configCompilerPath cfg)+ (configHcPkgPath cfg)+ defaultProgramConfiguration + (configVerbose cfg)++--+-- * Default config+--++defaultCabalDir :: IO FilePath+defaultCabalDir = getAppUserDataDirectory "cabal"++defaultConfigFile :: IO FilePath+defaultConfigFile = do dir <- defaultCabalDir+ return $ dir </> "config"++defaultCacheDir :: IO FilePath+defaultCacheDir = do dir <- defaultCabalDir+ return $ dir </> "packages"++defaultCompiler :: CompilerFlavor+defaultCompiler = fromMaybe GHC defaultCompilerFlavor++defaultUserInstallDirs :: CompilerFlavor -> IO InstallDirTemplates+defaultUserInstallDirs compiler =+ do installDirs <- defaultInstallDirs compiler True+ userPrefix <- defaultCabalDir+ return $ installDirs { prefixDirTemplate = toPathTemplate userPrefix }++defaultGlobalInstallDirs :: CompilerFlavor -> IO InstallDirTemplates+defaultGlobalInstallDirs compiler = defaultInstallDirs compiler True++defaultConfigFlags :: IO ConfigFlags+defaultConfigFlags = + do userInstallDirs <- defaultUserInstallDirs defaultCompiler+ globalInstallDirs <- defaultGlobalInstallDirs defaultCompiler+ cacheDir <- defaultCacheDir+ return $ ConfigFlags + { configCompiler = defaultCompiler+ , configCompilerPath = Nothing+ , configHcPkgPath = Nothing+ , configUserInstallDirs = userInstallDirs+ , configGlobalInstallDirs = globalInstallDirs+ , configCacheDir = cacheDir+ , configRepos = [Repo "hackage.haskell.org" "http://hackage.haskell.org/packages/archive"]+ , configVerbose = normal+ , configUserInstall = True+ }++--+-- * Config file reading+--++loadConfig :: FilePath -> IO ConfigFlags+loadConfig configFile = + do defaultConf <- defaultConfigFlags+ minp <- readFileIfExists configFile+ case minp of+ Nothing -> do hPutStrLn stderr $ "Config file " ++ configFile ++ " not found."+ hPutStrLn stderr $ "Writing default configuration to " ++ configFile ++ "."+ writeDefaultConfigFile configFile defaultConf+ return defaultConf+ Just inp -> case parseBasicStanza configFieldDescrs defaultConf inp of+ ParseOk ws conf -> + do mapM_ (hPutStrLn stderr . ("Config file warning: " ++)) ws+ return conf+ ParseFailed err -> + do hPutStrLn stderr $ "Error parsing config file " + ++ configFile ++ ": " ++ showPError err+ hPutStrLn stderr $ "Using default configuration."+ return defaultConf++writeDefaultConfigFile :: FilePath -> ConfigFlags -> IO ()+writeDefaultConfigFile file cfg = + do createDirectoryIfMissing True (takeDirectory file)+ writeFile file $ showFields configWriteFieldDescrs cfg++showConfig :: ConfigFlags -> String+showConfig = showFields configFieldDescrs++-- | All config file fields.+configFieldDescrs :: [FieldDescr ConfigFlags]+configFieldDescrs = + configWriteFieldDescrs+ ++ map userInstallDirField installDirDescrs+ ++ map globalInstallDirField installDirDescrs++-- | The subset of the config file fields that we write out+-- if the config file is missing.+configWriteFieldDescrs :: [FieldDescr ConfigFlags]+configWriteFieldDescrs =+ [ simpleField "compiler"+ (text . show) parseCompilerFlavor+ configCompiler (\c cfg -> cfg { configCompiler = c })+ , listField "repos"+ (text . showRepo) parseRepo+ configRepos (\rs cfg -> cfg { configRepos = rs })+ , simpleField "cachedir"+ (text . show) (readS_to_P reads)+ configCacheDir (\d cfg -> cfg { configCacheDir = d })+ , boolField "user-install" configUserInstall (\u cfg -> cfg { configUserInstall = u })+ ] ++installDirDescrs :: [FieldDescr InstallDirTemplates]+installDirDescrs =+ [ installDirField "prefix" prefixDirTemplate (\d ds -> ds { prefixDirTemplate = d })+ , installDirField "bindir" binDirTemplate (\d ds -> ds { binDirTemplate = d })+ , installDirField "libdir" libDirTemplate (\d ds -> ds { libDirTemplate = d })+ , installDirField "libexecdir" libexecDirTemplate (\d ds -> ds { libexecDirTemplate = d })+ , installDirField "datadir" dataDirTemplate (\d ds -> ds { dataDirTemplate = d })+ , installDirField "docdir" docDirTemplate (\d ds -> ds { docDirTemplate = d })+ , installDirField "htmldir" htmlDirTemplate (\d ds -> ds { htmlDirTemplate = d })+ ]+++userInstallDirField :: FieldDescr InstallDirTemplates -> FieldDescr ConfigFlags+userInstallDirField f = modifyFieldName ("user-"++) $+ liftField configUserInstallDirs + (\d cfg -> cfg { configUserInstallDirs = d }) + f++globalInstallDirField :: FieldDescr InstallDirTemplates -> FieldDescr ConfigFlags+globalInstallDirField f = modifyFieldName ("global-"++) $+ liftField configGlobalInstallDirs + (\d cfg -> cfg { configGlobalInstallDirs = d }) + f++installDirField :: String + -> (InstallDirTemplates -> PathTemplate) + -> (PathTemplate -> InstallDirTemplates -> InstallDirTemplates)+ -> FieldDescr InstallDirTemplates+installDirField name get set = + liftField get set $ field name (text . show) (readS_to_P reads)++modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a+modifyFieldName f d = d { fieldName = f (fieldName d) }++parseCompilerFlavor :: ReadP r CompilerFlavor+parseCompilerFlavor = + do s <- munch1 isAlphaNum+ return $ case map toLower s of+ "ghc" -> GHC+ "nhc" -> NHC+ "hugs" -> Hugs+ "hbc" -> HBC+ "helium" -> Helium+ "jhc" -> JHC+ _ -> OtherCompiler s++showRepo :: Repo -> String+showRepo repo = repoName repo ++ ":" ++ repoURL repo++parseRepo :: ReadP r Repo+parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.")+ char ':'+ url <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")+ return $ Repo { repoName = name, repoURL = url }+
+ Hackage/Dependency.hs view
@@ -0,0 +1,157 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Dependency+-- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Various kinds of dependency resolution and utilities.+-----------------------------------------------------------------------------+module Hackage.Dependency+ (+ resolveDependencies+ , resolveDependenciesLocal+ , packagesToInstall+ ) where++import Hackage.Config (listInstalledPackages)+import Hackage.Index (getKnownPackages)+import Hackage.Types + (ResolvedPackage(..), UnresolvedDependency(..), ConfigFlags (..), PkgInfo (..))++import Distribution.Version (Dependency(..), withinRange)+import Distribution.Package (PackageIdentifier(..))+import Distribution.PackageDescription + (PackageDescription(buildDepends)+ , GenericPackageDescription+ , finalizePackageDescription)+import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerVersion)+import Distribution.Simple.Program (ProgramConfiguration)++import Control.Monad (mplus)+import Data.Char (toLower)+import Data.List (nub, nubBy, maximumBy, isPrefixOf)+import Data.Maybe (fromMaybe)+import qualified System.Info (arch,os)+++resolveDependencies :: ConfigFlags+ -> Compiler+ -> ProgramConfiguration+ -> [UnresolvedDependency]+ -> IO [ResolvedPackage]+resolveDependencies cfg comp conf deps + = do installed <- listInstalledPackages cfg comp conf+ available <- getKnownPackages cfg+ return [resolveDependency comp installed available dep opts + | UnresolvedDependency dep opts <- deps]++-- | Resolve dependencies of a local package description. This is used+-- when the top-level package does not come from hackage.+resolveDependenciesLocal :: ConfigFlags+ -> Compiler+ -> ProgramConfiguration+ -> GenericPackageDescription+ -> [String]+ -> IO [ResolvedPackage]+resolveDependenciesLocal cfg comp conf desc opts+ = do installed <- listInstalledPackages cfg comp conf+ available <- getKnownPackages cfg+ return [resolveDependency comp installed available dep []+ | dep <- getDependencies comp installed available desc opts]++resolveDependency :: Compiler+ -> [PackageIdentifier] -- ^ Installed packages.+ -> [PkgInfo] -- ^ Installable packages+ -> Dependency+ -> [String] -- ^ Options for this dependency+ -> ResolvedPackage+resolveDependency comp installed available dep opts+ = fromMaybe (Unavailable dep) $ resolveFromInstalled `mplus` resolveFromAvailable+ where+ resolveFromInstalled = fmap (Installed dep) $ latestInstalledSatisfying installed dep+ resolveFromAvailable = + do pkg <- latestAvailableSatisfying available dep+ let deps = getDependencies comp installed available (pkgDesc pkg) opts+ resolved = map (\d -> resolveDependency comp installed available d []) deps+ return $ Available dep pkg opts resolved++-- | Gets the latest installed package satisfying a dependency.+latestInstalledSatisfying :: [PackageIdentifier] + -> Dependency -> Maybe PackageIdentifier+latestInstalledSatisfying = latestSatisfying id++-- | Gets the latest available package satisfying a dependency.+latestAvailableSatisfying :: [PkgInfo] + -> Dependency -> Maybe PkgInfo+latestAvailableSatisfying = latestSatisfying pkgInfoId++latestSatisfying :: (a -> PackageIdentifier) + -> [a]+ -> Dependency+ -> Maybe a+latestSatisfying f xs dep =+ case filter ((`satisfies` dep) . f) xs of+ [] -> Nothing+ ys -> Just $ maximumBy (comparing (pkgVersion . f)) ys+ where comparing g a b = g a `compare` g b++-- | Checks if a package satisfies a dependency.+satisfies :: PackageIdentifier -> Dependency -> Bool+satisfies pkg (Dependency depName vrange)+ = pkgName pkg == depName && pkgVersion pkg `withinRange` vrange++-- | Gets the dependencies of an available package.+getDependencies :: Compiler + -> [PackageIdentifier] -- ^ Installed packages.+ -> [PkgInfo] -- ^ Available packages+ -> GenericPackageDescription+ -> [String] -- ^ Options+ -> [Dependency] + -- ^ If successful, this is the list of dependencies.+ -- If flag assignment failed, this is the list of+ -- missing dependencies.+getDependencies comp installed available pkg opts+ = case e of+ Left missing -> missing+ Right (desc,_) -> buildDepends desc+ where + flags = configurationsFlags opts+ e = finalizePackageDescription + flags+ (Just $ nub $ installed ++ map pkgInfoId available) + System.Info.os+ System.Info.arch+ (showCompilerId comp, compilerVersion comp)+ pkg++-- | Extracts configurations flags from a list of options.+configurationsFlags :: [String] -> [(String, Bool)]+configurationsFlags = concatMap flag+ where+ flag o | "--flags=" `isPrefixOf` o = map tagWithValue $ words $ removeQuotes $ drop 8 o+ | "-f" `isPrefixOf` o = [tagWithValue $ drop 2 o]+ | otherwise = []+ removeQuotes (c:s) | c == '"' || c == '\'' = take (length s - 1) s+ removeQuotes s = s+ tagWithValue ('-':name) = (map toLower name, False)+ tagWithValue name = (map toLower name, True)++packagesToInstall :: [ResolvedPackage] + -> Either [Dependency] [(PkgInfo, [String])]+ -- ^ Either a list of missing dependencies, or a list+ -- of packages to install, with their options.+packagesToInstall xs | null missing = Right toInstall+ | otherwise = Left missing+ where + flattened = concatMap flatten xs+ missing = [d | Left d <- flattened]+ toInstall = nubBy samePackage [x | Right x <- flattened]+ samePackage a b = pkgInfoId (fst a) == pkgInfoId (fst b)+ flatten (Installed _ _) = []+ flatten (Available _ p opts deps) = concatMap flatten deps ++ [Right (p,opts)]+ flatten (Unavailable dep) = [Left dep]+
+ Hackage/Fetch.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Fetch+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+--+-----------------------------------------------------------------------------+module Hackage.Fetch+ (+ -- * Commands+ fetch+ , -- * Utilities+ fetchPackage+ , isFetched+ , readURI+ , downloadIndex+ ) where++import Network.URI (URI,parseURI,uriScheme,uriPath)+import Network.HTTP (ConnError(..), Request (..), simpleHTTP+ , Response(..), RequestMethod (..))++import Control.Exception (bracket)+import Control.Monad (filterM)+import Text.Printf (printf)+import System.Directory (doesFileExist, createDirectoryIfMissing)++import Hackage.Types (ConfigFlags (..), UnresolvedDependency (..), Repo(..), PkgInfo, pkgInfoId)+import Hackage.Config (repoCacheDir, packageFile, packageDir, pkgURL, message)+import Hackage.Dependency (resolveDependencies, packagesToInstall)+import Hackage.Utils++import Distribution.Package (showPackageId)+import Distribution.Simple.Compiler (Compiler)+import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Verbosity+import System.FilePath ((</>), (<.>))+import System.Directory (copyFile)+import System.IO (IOMode(..), hPutStr, Handle, hClose, openBinaryFile)+++readURI :: URI -> IO String+readURI uri+ | uriScheme uri == "file:" = (readFile $ uriPath uri)+ | otherwise = do+ eitherResult <- simpleHTTP (Request uri GET [] "")+ case eitherResult of+ Left err -> fail $ printf "Failed to download '%s': %s" (show uri) (show err)+ Right rsp+ | rspCode rsp == (2,0,0) -> return (rspBody rsp)+ | otherwise -> fail $ "Failed to download '" ++ show uri ++ "': Invalid HTTP code: " ++ show (rspCode rsp)++downloadURI :: FilePath -- ^ Where to put it+ -> URI -- ^ What to download+ -> IO (Maybe ConnError)+downloadURI path uri+ | uriScheme uri == "file:" = do+ copyFile (uriPath uri) path+ return Nothing+ | otherwise = do+ eitherResult <- simpleHTTP request+ case eitherResult of+ Left err -> return (Just err)+ Right rsp+ | rspCode rsp == (2,0,0) -> withBinaryFile path WriteMode (`hPutStr` rspBody rsp) + >> return Nothing+ | otherwise -> return (Just (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp))))+ where request = Request uri GET [] ""++++downloadFile :: FilePath+ -> String+ -> IO (Maybe ConnError)+downloadFile path url+ = case parseURI url of+ Just parsed -> downloadURI path parsed+ Nothing -> return (Just (ErrorMisc ("Failed to parse url: " ++ show url)))+++-- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.+downloadPackage :: ConfigFlags -> PkgInfo -> IO String+downloadPackage cfg pkg+ = do let url = pkgURL pkg+ dir = packageDir cfg pkg+ path = packageFile cfg pkg+ message cfg verbose $ "GET " ++ show url+ createDirectoryIfMissing True dir+ mbError <- downloadFile path url+ case mbError of+ Just err -> fail $ printf "Failed to download '%s': %s" (showPackageId (pkgInfoId pkg)) (show err)+ Nothing -> return path++-- Downloads an index file to [config-dir/packages/serv-id].+downloadIndex :: ConfigFlags -> Repo -> IO FilePath+downloadIndex cfg repo+ = do let url = repoURL repo ++ "/" ++ "00-index.tar.gz"+ dir = repoCacheDir cfg repo+ path = dir </> "00-index" <.> "tar.gz"+ createDirectoryIfMissing True dir+ mbError <- downloadFile path url+ case mbError of+ Just err -> fail $ printf "Failed to download index '%s'" (show err)+ Nothing -> return path++-- |Returns @True@ if the package has already been fetched.+isFetched :: ConfigFlags -> PkgInfo -> IO Bool+isFetched cfg pkg = doesFileExist (packageFile cfg pkg)++-- |Fetch a package if we don't have it already.+fetchPackage :: ConfigFlags -> PkgInfo -> IO String+fetchPackage cfg pkg+ = do fetched <- isFetched cfg pkg+ if fetched+ then do printf "'%s' is cached.\n" (showPackageId (pkgInfoId pkg))+ return (packageFile cfg pkg)+ else do printf "Downloading '%s'...\n" (showPackageId (pkgInfoId pkg))+ downloadPackage cfg pkg++-- |Fetch a list of packages and their dependencies.+fetch :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()+fetch cfg comp conf _globalArgs deps+ = do depTree <- resolveDependencies cfg comp conf deps+ case packagesToInstall depTree of+ Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing+ Right pkgs -> do ps <- filterM (fmap not . isFetched cfg) $ map fst pkgs+ mapM_ (fetchPackage cfg) ps++withBinaryFile :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile name mode = bracket (openBinaryFile name mode) hClose
+ Hackage/Index.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Index+-- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Reading the local package index.+-----------------------------------------------------------------------------+module Hackage.Index (getKnownPackages) where++import Hackage.Config+import Hackage.Types+import Hackage.Tar++import Prelude hiding (catch)+import Control.Exception (catch, Exception(IOException))+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.IO (hPutStrLn, stderr)+import System.IO.Error (isDoesNotExistError)++import Distribution.PackageDescription (parsePackageDescription, ParseResult(..))+import Distribution.Package (PackageIdentifier(..))+import Distribution.Version (readVersion)++getKnownPackages :: ConfigFlags -> IO [PkgInfo]+getKnownPackages cfg+ = fmap concat $ mapM (readRepoIndex cfg) $ configRepos cfg++readRepoIndex :: ConfigFlags -> Repo -> IO [PkgInfo]+readRepoIndex cfg repo =+ do let indexFile = repoCacheDir cfg repo </> "00-index.tar"+ fmap (parseRepoIndex repo) (BS.readFile indexFile)+ `catch` (\e -> do case e of+ IOException ioe | isDoesNotExistError ioe ->+ hPutStrLn stderr "The package list does not exist. Run 'cabal update' to download it."+ _ -> hPutStrLn stderr ("Error: " ++ show e)+ return [])++parseRepoIndex :: Repo -> ByteString -> [PkgInfo]+parseRepoIndex repo s =+ do (hdr, content) <- readTarArchive s+ if takeExtension (tarFileName hdr) == ".cabal"+ then case splitDirectories (normalise (tarFileName hdr)) of+ [pkgname,vers,_] ->+ let descr = case parsePackageDescription (BS.unpack content) of+ ParseOk _ d -> d+ _ -> error $ "Couldn't read cabal file "+ ++ show (tarFileName hdr)+ in case readVersion vers of+ Just ver ->+ return $ PkgInfo {+ pkgInfoId = PackageIdentifier pkgname ver,+ pkgRepo = repo,+ pkgDesc = descr+ }+ _ -> []+ _ -> []+ else []
+ Hackage/Info.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Info+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- High level interface to a dry-run package installation.+-----------------------------------------------------------------------------+module Hackage.Info where++import Hackage.Config+import Hackage.Dependency +import Hackage.Fetch+import Hackage.Types +import Hackage.Utils++import Distribution.Package (showPackageId)+import Distribution.ParseUtils (showDependency)+import Distribution.Simple.Compiler (Compiler)+import Distribution.Simple.Program (ProgramConfiguration)++import Data.List (intersperse, nubBy)+import Text.Printf (printf)++info :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()+info cfg comp conf _globalArgs deps+ = do apkgs <- resolveDependencies cfg comp conf deps+ mapM_ (infoPkg cfg) $ flattenResolvedPackages apkgs+ case packagesToInstall apkgs of+ Left missing -> + do putStrLn "The requested packages cannot be installed, because of missing dependencies:"+ putStrLn $ showDependencies missing+ Right pkgs ->+ do putStrLn "These packages would be installed:"+ putStrLn $ concat $ intersperse ", " [showPackageId (pkgInfoId pkg) | (pkg,_) <- pkgs]+ ++flattenResolvedPackages :: [ResolvedPackage] -> [ResolvedPackage]+flattenResolvedPackages = nubBy fulfillSame. concatMap flatten+ where flatten p@(Available _ _ _ deps) = p : flattenResolvedPackages deps+ flatten p = [p]+ fulfillSame a b = fulfills a == fulfills b++infoPkg :: ConfigFlags -> ResolvedPackage -> IO ()+infoPkg _ (Installed dep p)+ = do printf " Requested: %s\n" (show $ showDependency dep)+ printf " Installed: %s\n\n" (showPackageId p)+infoPkg cfg (Available dep pkg opts deps)+ = do fetched <- isFetched cfg pkg+ let pkgFile = if fetched then packageFile cfg pkg+ else "*Not downloaded"+ printf " Requested: %s\n" (show $ showDependency dep)+ printf " Using: %s\n" (showPackageId (pkgInfoId pkg))+ printf " Depends: %s\n" (showDependencies $ map fulfills deps)+ printf " Options: %s\n" (unwords opts)+ printf " Location: %s\n" (pkgURL pkg)+ printf " Local: %s\n\n" pkgFile+infoPkg _ (Unavailable dep)+ = do printf " Requested: %s\n" (show $ showDependency dep)+ printf " Not available!\n\n"
+ Hackage/Install.hs view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Install+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Hackage.Install+ ( install+ ) where++import Control.Exception (bracket_)+import Control.Monad (when)+import System.Directory (getTemporaryDirectory, createDirectoryIfMissing+ ,removeDirectoryRecursive, doesFileExist)+import System.FilePath ((</>),(<.>))++import Text.Printf (printf)+++import Hackage.Config (message)+import Hackage.Dependency (resolveDependencies, resolveDependenciesLocal, packagesToInstall)+import Hackage.Fetch (fetchPackage)+import Hackage.Tar (extractTarGzFile)+import Hackage.Types (ConfigFlags(..), UnresolvedDependency(..)+ , PkgInfo(..))+import Hackage.Utils++import Distribution.Simple.Compiler (Compiler(..))+import Distribution.Simple.InstallDirs (InstallDirs(..), absoluteInstallDirs)+import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Simple.SetupWrapper (setupWrapper)+import Distribution.Simple.Setup (CopyDest(..))+import Distribution.Simple.Utils (defaultPackageDesc)+import Distribution.Package (showPackageId, PackageIdentifier(..))+import Distribution.PackageDescription (packageDescription, readPackageDescription, package)+import Distribution.Verbosity+++++-- |Installs the packages needed to satisfy a list of dependencies.+install :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()+install cfg comp conf globalArgs deps+ | null deps = installLocalPackage cfg comp conf globalArgs+ | otherwise = installRepoPackages cfg comp conf globalArgs deps++-- | Install the unpacked package in the current directory, and all its dependencies.+installLocalPackage :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> IO ()+installLocalPackage cfg comp conf globalArgs =+ do cabalFile <- defaultPackageDesc (configVerbose cfg)+ desc <- readPackageDescription (configVerbose cfg) cabalFile+ resolvedDeps <- resolveDependenciesLocal cfg comp conf desc globalArgs+ case packagesToInstall resolvedDeps of+ Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing+ Right pkgs -> installPackages cfg comp globalArgs pkgs+ let pkgId = package (packageDescription desc)+ installUnpackedPkg cfg comp globalArgs pkgId [] Nothing++installRepoPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> [String] -> [UnresolvedDependency] -> IO ()+installRepoPackages cfg comp conf globalArgs deps =+ do resolvedDeps <- resolveDependencies cfg comp conf deps+ case packagesToInstall resolvedDeps of+ Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing+ Right [] -> message cfg normal "All requested packages already installed. Nothing to do."+ Right pkgs -> installPackages cfg comp globalArgs pkgs++-- Attach the correct prefix flag to configure commands,+-- correct --user flag to install commands and no options to other commands.+mkPkgOps :: ConfigFlags -> Compiler -> PackageIdentifier -> String -> [String] -> [String]+mkPkgOps cfg comp pkgId cmd ops = verbosity +++ case cmd of+ "configure" -> user ++ hcPath ++ hcPkgPath ++ installDirFlags installDirs ++ ops+ "install" -> user+ _ -> []+ where verbosity = ["-v" ++ showForCabal (configVerbose cfg)]+ user = if configUserInstall cfg then ["--user"] else []+ hcPath = maybe [] (\path -> ["--with-compiler=" ++ path]) (configCompilerPath cfg)+ hcPkgPath = maybe [] (\path -> ["--with-hc-pkg=" ++ path]) (configHcPkgPath cfg)+ installDirTemplates | configUserInstall cfg = configUserInstallDirs cfg+ | otherwise = configGlobalInstallDirs cfg+ installDirs = absoluteInstallDirs pkgId (compilerId comp) NoCopyDest installDirTemplates++installDirFlags :: InstallDirs FilePath -> [String]+installDirFlags dirs =+ [flag "prefix" prefix,+ flag "bindir" bindir,+ flag "libdir" libdir,+-- flag "dynlibdir" dynlibdir, -- not accepted as argument by cabal?+ flag "libexecdir" libexecdir,+-- flag "progdir" progdir, -- not accepted as argument by cabal?+-- flag "includedir" includedir, -- not accepted as argument by cabal?+ flag "datadir" datadir,+ flag "docdir" docdir,+ flag "htmldir" htmldir]+ where flag s f = "--" ++ s ++ "=" ++ f dirs++installPackages :: ConfigFlags+ -> Compiler+ -> [String] -- ^Options which will be parse to every package.+ -> [(PkgInfo,[String])] -- ^ (Package, list of configure options)+ -> IO ()+installPackages cfg comp globalArgs pkgs =+ mapM_ (installPkg cfg comp globalArgs) pkgs+++{-|+ Download, build and install a given package with some given flags.++ The process is divided up in a few steps:++ * The package is downloaded to {config-dir}\/packages\/{pkg-id} (if not already there).++ * The fetched tarball is then moved to a temporary directory (\/tmp on linux) and unpacked.++ * setupWrapper (equivalent to cabal-setup) is called with the options+ \'configure\' and the user specified options, \'--user\'+ if the 'configUser' flag is @True@ and install directory flags depending on + @configUserInstallDirs@ or @configGlobalInstallDirs@.++ * setupWrapper \'build\' is called with no options.++ * setupWrapper \'install\' is called with the \'--user\' flag if 'configUserInstall' is @True@.++ * The installation finishes by deleting the unpacked tarball.+-} +installPkg :: ConfigFlags+ -> Compiler+ -> [String] -- ^Options which will be parse to every package.+ -> (PkgInfo,[String]) -- ^(Package, list of configure options)+ -> IO ()+installPkg cfg comp globalArgs (pkg,opts)+ = do pkgPath <- fetchPackage cfg pkg+ tmp <- getTemporaryDirectory+ let p = pkgInfoId pkg+ tmpDirPath = tmp </> printf "TMP%sTMP" (showPackageId p)+ path = tmpDirPath </> showPackageId p+ bracket_ (createDirectoryIfMissing True tmpDirPath)+ (removeDirectoryRecursive tmpDirPath)+ (do message cfg verbose (printf "Extracting %s to %s..." pkgPath tmpDirPath)+ extractTarGzFile (Just tmpDirPath) pkgPath+ let descFilePath = tmpDirPath </> showPackageId p </> pkgName p <.> "cabal"+ e <- doesFileExist descFilePath+ when (not e) $ fail $ "Package .cabal file not found: " ++ show descFilePath+ installUnpackedPkg cfg comp globalArgs p opts (Just path)+ return ())++installUnpackedPkg :: ConfigFlags -> Compiler + -> [String] -- ^ Arguments for all packages+ -> PackageIdentifier+ -> [String] -- ^ Arguments for this package+ -> Maybe FilePath -- ^ Directory to change to before starting the installation.+ -> IO ()+installUnpackedPkg cfg comp globalArgs pkgId opts mpath+ = do setup "configure"+ setup "build"+ setup "install"+ where+ setup cmd + = do let cmdOps = mkPkgOps cfg comp pkgId cmd (globalArgs++opts)+ message cfg verbose $ + unwords ["setupWrapper", show (cmd:cmdOps), show mpath]+ setupWrapper (cmd:cmdOps) mpath
+ Hackage/List.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Install+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Hackage.List+ ( list -- :: ConfigFlags -> [UnresolvedDependency] -> IO ()+ ) where++import Data.List (nubBy, sortBy, groupBy, intersperse, isPrefixOf, tails)+import Data.Char as Char (toLower)+import Distribution.Package+import Distribution.PackageDescription+import Distribution.Version (showVersion)+import Hackage.Index (getKnownPackages)+import Hackage.Types (PkgInfo(..), ConfigFlags(..), {- UnresolvedDependency(..)-} )++-- |Show information about packages+list :: ConfigFlags -> [String] -> IO ()+list cfg pats = do+ pkgs <- getKnownPackages cfg+ let pkgs' | null pats = pkgs+ | otherwise = nubBy samePackage (concatMap (findInPkgs pkgs) pats')+ pats' = map lcase pats+ putStrLn+ . unlines+ . map (showPkgVersions . map (packageDescription . pkgDesc))+ . groupBy sameName+ . sortBy (comparing nameAndVersion)+ $ pkgs'++ where+ findInPkgs :: [PkgInfo] -> String -> [PkgInfo]+ findInPkgs pkgs pat =+ filter (isInfixOf pat . lcase . pkgName . pkgInfoId) pkgs+ lcase = map Char.toLower+ nameAndVersion p = (lcase name, name, version)+ where name = pkgName (pkgInfoId p)+ version = pkgVersion (pkgInfoId p)+ samePackage a b = nameAndVersion a == nameAndVersion b+ sameName a b = pkgName (pkgInfoId a) == pkgName (pkgInfoId b)++showPkgVersions :: [PackageDescription] -> String+showPkgVersions pkgs =+ padTo 35 (pkgName (package pkg)+ ++ " [" ++ concat (intersperse ", " versions) ++ "] ")+ ++ synopsis pkg+ where+ pkg = last pkgs+ versions = map (showVersion . pkgVersion . package) pkgs+ padTo n s = s ++ (replicate (n - length s) ' ')++comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering+comparing p x y = compare (p x) (p y)++isInfixOf :: String -> String -> Bool+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+ Hackage/Setup.hs view
@@ -0,0 +1,204 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Setup+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+--+-----------------------------------------------------------------------------+module Hackage.Setup+ ( parsePackageArgs+ , parseGlobalArgs+ , configFromOptions+ ) where++import Control.Monad (when)+import Distribution.Compiler (CompilerFlavor(..))+import Distribution.Simple.InstallDirs (InstallDirTemplates(..), toPathTemplate)+import Distribution.Verbosity+import Data.List (find)+import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), usageInfo, getOpt')+import System.Exit (exitWith, ExitCode (..))+import System.Environment (getProgName)++import Hackage.Types (Action (..), Option(..), ConfigFlags(..)+ , UnresolvedDependency (..))+import Hackage.Utils (readPToMaybe, parseDependencyOrPackageId)+++globalOptions :: [OptDescr Option]+globalOptions =+ [ Option "g" ["ghc"] (NoArg (OptCompilerFlavor GHC)) "Compile with GHC"+ , Option "n" ["nhc"] (NoArg (OptCompilerFlavor NHC)) "Compile with NHC"+ , Option "" ["hugs"] (NoArg (OptCompilerFlavor Hugs)) "Compile with hugs"+ , Option "w" ["with-compiler"] (reqPathArg OptCompiler)+ "Give the path to a particular compiler"+ , Option "" ["with-hc-pkg"] (reqPathArg OptHcPkg)+ "Give the path to the package tool"+ , Option "c" ["config-file"] (reqPathArg OptConfigFile)+ ("Override the path to the config dir.")+ , Option "" ["cache-dir"] (reqPathArg OptCacheDir)+ ("Override the path to the package cache dir.")+ , Option "" ["prefix"] (reqDirArg OptPrefix)+ "Bake this prefix in preparation of installation"+ , Option "" ["bindir"] (reqDirArg OptBinDir)+ "Installation directory for executables"+ , Option "" ["libdir"] (reqDirArg OptLibDir)+ "Installation directory for libraries"+ , Option "" ["libsubdir"] (reqDirArg OptLibSubDir)+ "Subdirectory of libdir in which libs are installed"+ , Option "" ["libexecdir"] (reqDirArg OptLibExecDir)+ "Installation directory for program executables"+ , Option "" ["datadir"] (reqDirArg OptDataDir)+ "Installation directory for read-only data"+ , Option "" ["datasubdir"] (reqDirArg OptDataSubDir)+ "Subdirectory of datadir in which data files are installed"+ , Option "" ["docdir"] (reqDirArg OptDocDir)+ "Installation directory for documentation"+ , Option "" ["htmldir"] (reqDirArg OptHtmlDir)+ "Installation directory for HTML documentation"+ , Option "" ["user"] (NoArg (OptUserInstall True))+ "Upon registration, register this package in the user's local package database"+ , Option "" ["global"] (NoArg (OptUserInstall False))+ "Upon registration, register this package in the system-wide package database"+ , Option "h?" ["help"] (NoArg OptHelp) "Show this help text"+ , Option "v" ["verbose"] (OptArg (OptVerbose . flagToVerbosity) "n")+ "Control verbosity (n is 0--3, normal verbosity level is 1, -v alone is equivalent to -v2)"+ ]++reqPathArg :: (FilePath -> a) -> ArgDescr a+reqPathArg constr = ReqArg constr "PATH"++reqDirArg :: (FilePath -> a) -> ArgDescr a+reqDirArg constr = ReqArg constr "DIR"++configFromOptions :: ConfigFlags -> [Option] -> ConfigFlags+configFromOptions conf opts = foldr f conf opts+ where + -- figure out up front if this is a user or global install+ userInstall = last $ configUserInstall conf : [u | OptUserInstall u <- opts]+ f o cfg = case o of+ OptCompilerFlavor c -> cfg { configCompiler = c}+ OptCompiler p -> cfg { configCompilerPath = Just p }+ OptHcPkg p -> cfg { configHcPkgPath = Just p }+ OptConfigFile _ -> cfg+ OptCacheDir d -> cfg { configCacheDir = d }+ OptPrefix d -> lib (\ds x -> ds { prefixDirTemplate = x }) d+ OptBinDir d -> lib (\ds x -> ds { binDirTemplate = x }) d+ OptLibDir d -> lib (\ds x -> ds { libDirTemplate = x }) d+ OptLibSubDir d -> lib (\ds x -> ds { libSubdirTemplate = x }) d+ OptLibExecDir d -> lib (\ds x -> ds { libexecDirTemplate = x }) d+ OptDataDir d -> lib (\ds x -> ds { dataDirTemplate = x }) d+ OptDataSubDir d -> lib (\ds x -> ds { dataSubdirTemplate = x }) d+ OptDocDir d -> lib (\ds x -> ds { docDirTemplate = x }) d+ OptHtmlDir d -> lib (\ds x -> ds { htmlDirTemplate = x }) d+ OptUserInstall u -> cfg { configUserInstall = u }+ OptHelp -> error "Got to setFlagsFromOptions OptHelp"+ OptVerbose v -> cfg { configVerbose = v }+ where + -- This is a bit of a hack to allow just one set of installdir command-line+ -- options. Settings on the comman-line are for a single install session only,+ -- which will be either a user or global install.+ lib g d | userInstall = cfg { configUserInstallDirs = g (configUserInstallDirs cfg) d' }+ | otherwise = cfg { configGlobalInstallDirs = g (configGlobalInstallDirs cfg) d' }+ where d' = toPathTemplate d++data Cmd = Cmd {+ cmdName :: String,+ cmdHelp :: String, -- Short description+ cmdDescription :: String, -- Long description+ cmdOptions :: [OptDescr Option],+ cmdAction :: Action+ }++commandList :: [Cmd]+commandList = [fetchCmd, installCmd, updateCmd, cleanCmd, listCmd, infoCmd]++lookupCommand :: String -> Maybe Cmd+lookupCommand name = find ((==name) . cmdName) commandList++printGlobalHelp :: IO ()+printGlobalHelp = do pname <- getProgName+ let syntax_line = concat [ "Usage: ", pname+ , " [GLOBAL FLAGS]\n or: ", pname+ , " COMMAND [FLAGS]\n\nGlobal flags:"]+ putStrLn (usageInfo syntax_line globalOptions)+ putStrLn "Commands:"+ let maxlen = maximum [ length (cmdName cmd) | cmd <- commandList ]+ sequence_ [ do putStr " "+ putStr (align maxlen (cmdName cmd))+ putStr " "+ putStrLn (cmdHelp cmd)+ | cmd <- commandList ]+ where align n str = str ++ replicate (n - length str) ' '++parseGlobalArgs :: [String] -> IO (Action,[Option],[String])+parseGlobalArgs opts =+ do let (flags, args, unrec, errs) = getOpt' RequireOrder globalOptions opts+ when (OptHelp `elem` flags) $ + do printGlobalHelp+ exitWith ExitSuccess+ when (not (null errs)) $ + do putStrLn "Errors:"+ mapM_ putStrLn errs+ exitWith (ExitFailure 1)+ when (not (null unrec)) $ + do putStrLn "Unrecognized options:"+ mapM_ putStrLn unrec+ exitWith (ExitFailure 1)+ case args of+ [] -> do putStrLn $ "No command given (try --help)"+ exitWith (ExitFailure 1)+ cname:cargs -> case lookupCommand cname of+ Just cmd -> return (cmdAction cmd, flags, cargs)+ Nothing -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)"+ exitWith (ExitFailure 1)++mkCmd :: String -> String -> String -> Action -> Cmd+mkCmd name help desc action =+ Cmd { cmdName = name+ , cmdHelp = help+ , cmdDescription = desc+ , cmdOptions = []+ , cmdAction = action+ }++fetchCmd :: Cmd+fetchCmd = mkCmd "fetch" "Downloads packages for later installation or study." "" FetchCmd++installCmd :: Cmd+installCmd = mkCmd "install" "Installs a list of packages." "" InstallCmd++listCmd :: Cmd+listCmd = mkCmd "list" "List available packages on the server." "" ListCmd++updateCmd :: Cmd+updateCmd = mkCmd "update" "Updates list of known packages" "" UpdateCmd++cleanCmd :: Cmd+cleanCmd = mkCmd "clean" "Removes downloaded files" "" CleanCmd++infoCmd :: Cmd+infoCmd = mkCmd "info" "Emit some info"+ "Emits information about dependency resolution" InfoCmd++parsePackageArgs :: Action -> [String] -> IO ([String],[UnresolvedDependency])+parsePackageArgs _ args+ = return (globalArgs,parsePkgArgs pkgs)+ where (globalArgs,pkgs) = break (not.(==)'-'.head) args+ parseDep dep+ = case readPToMaybe parseDependencyOrPackageId dep of+ Nothing -> error ("Failed to parse package dependency: " ++ show dep)+ Just x -> x+ parsePkgArgs [] = []+ parsePkgArgs (x:xs)+ = let (args',rest) = break (not.(==) '-'.head) xs+ in (UnresolvedDependency+ { dependency = parseDep x+ , depOptions = args' }+ ):parsePkgArgs rest+
+ Hackage/Tar.hs view
@@ -0,0 +1,162 @@+-- | Simplistic TAR archive reading. Only gets the file names and file contents.+module Hackage.Tar (TarHeader(..), TarFileType(..),+ readTarArchive, extractTarArchive, + extractTarGzFile, gunzip) where++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Int (Int8, Int64)+import Data.List (unfoldr)+import Data.Maybe (catMaybes)+import Numeric (readOct)+import System.Directory (Permissions(..), setPermissions, createDirectoryIfMissing, copyFile)+import System.FilePath ((</>), isValid, isAbsolute)+import System.Posix.Types (FileMode)++-- GNU gzip+import Codec.Compression.GZip (decompress)++-- Or use Ian's gunzip:+-- import Codec.Compression.GZip.GUnZip (gunzip)++gunzip :: ByteString -> ByteString+gunzip = decompress++data TarHeader = TarHeader {+ tarFileName :: FilePath,+ tarFileMode :: FileMode,+ tarFileType :: TarFileType,+ tarLinkTarget :: FilePath+ } deriving Show++data TarFileType = TarNormalFile+ | TarHardLink+ | TarSymbolicLink+ | TarDirectory+ | TarOther Char+ deriving (Eq,Show)++readTarArchive :: ByteString -> [(TarHeader,ByteString)]+readTarArchive = catMaybes . unfoldr getTarEntry++extractTarArchive :: Maybe FilePath -> [(TarHeader,ByteString)] -> IO ()+extractTarArchive mdir = mapM_ (uncurry (extractEntry mdir))++extractTarGzFile :: Maybe FilePath -- ^ Destination directory+ -> FilePath -- ^ Tarball+ -> IO ()+extractTarGzFile mdir file = + BS.readFile file >>= extractTarArchive mdir . readTarArchive . decompress {- gunzip -}++--+-- * Extracting+--++extractEntry :: Maybe FilePath -> TarHeader -> ByteString -> IO ()+extractEntry mdir hdr cnt+ = do path <- relativizePath mdir (tarFileName hdr)+ let setPerms = setPermissions path (fileModeToPermissions (tarFileMode hdr))+ copyLinked = relativizePath mdir (tarLinkTarget hdr) >>= copyFile path+ case tarFileType hdr of+ TarNormalFile -> BS.writeFile path cnt >> setPerms+ TarHardLink -> copyLinked >> setPerms+ TarSymbolicLink -> copyLinked+ TarDirectory -> createDirectoryIfMissing False path >> setPerms+ TarOther _ -> return () -- FIXME: warning?++relativizePath :: Monad m => Maybe FilePath -> FilePath -> m FilePath+relativizePath mdir file+ | isAbsolute file = fail $ "Absolute file name in TAR archive: " ++ show file+ | not (isValid file) = fail $ "Invalid file name in TAR archive: " ++ show file+ | otherwise = return $ maybe file (</> file) mdir++fileModeToPermissions :: FileMode -> Permissions+fileModeToPermissions m = + Permissions {+ readable = m .&. ownerReadMode /= 0,+ writable = m .&. ownerWriteMode /= 0,+ executable = m .&. ownerExecuteMode /= 0,+ searchable = m .&. ownerExecuteMode /= 0+ }++ownerReadMode :: FileMode+ownerReadMode = 0o000400++ownerWriteMode :: FileMode+ownerWriteMode = 0o000200++ownerExecuteMode :: FileMode+ownerExecuteMode = 0o000100++--+-- * Reading+--++getTarEntry :: ByteString -> Maybe (Maybe (TarHeader,ByteString), ByteString)+getTarEntry bs | endBlock = Nothing+ | BS.length hdr < 512 = error "Truncated TAR archive."+ | not (checkChkSum hdr chkSum) = error "TAR checksum error."+ | otherwise = Just (Just (info, cnt), bs''')++ where (hdr,bs') = BS.splitAt 512 bs++ endBlock = getByte 0 hdr == '\0'++ fileSuffix = getString 0 100 hdr+ mode = getOct 100 8 hdr+ chkSum = getOct 148 8 hdr+ typ = getByte 156 hdr+ size = getOct 124 12 hdr+ linkTarget = getString 157 100 hdr+ filePrefix = getString 345 155 hdr++ padding = (512 - size) `mod` 512+ (cnt,bs'') = BS.splitAt size bs'+ bs''' = BS.drop padding bs''++ fileType = case typ of+ '\0'-> TarNormalFile+ '0' -> TarNormalFile+ '1' -> TarHardLink+ '2' -> TarSymbolicLink+ '5' -> TarDirectory+ c -> TarOther c+ + path = filePrefix ++ fileSuffix+ info = TarHeader { tarFileName = path, + tarFileMode = mode,+ tarFileType = fileType,+ tarLinkTarget = linkTarget }++checkChkSum :: ByteString -> Int -> Bool+checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr'+ where + -- replace the checksum with spaces+ hdr' = BS.concat [BS.take 148 hdr, BS.replicate 8 ' ', BS.drop 156 hdr]+ -- tar.info says that Sun tar is buggy and + -- calculates the checksum using signed chars+ chkSum = BS.foldl' (\x y -> x + ord y) 0+ signedChkSum = BS.foldl' (\x y -> x + (ordSigned y)) 0++ordSigned :: Char -> Int+ordSigned c = fromIntegral (fromIntegral (ord c) :: Int8)++-- * TAR format primitive input++getOct :: Integral a => Int64 -> Int64 -> ByteString -> a+getOct off len = parseOct . getString off len+ where parseOct "" = 0+ parseOct s = case readOct s of+ [(x,_)] -> x+ _ -> error $ "Number format error: " ++ show s++getBytes :: Int64 -> Int64 -> ByteString -> ByteString+getBytes off len = BS.take len . BS.drop off++getByte :: Int64 -> ByteString -> Char+getByte off bs = BS.index bs off++getString :: Int64 -> Int64 -> ByteString -> String+getString off len = BS.unpack . BS.takeWhile (/='\0') . getBytes off len
+ Hackage/Types.hs view
@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Types+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.+-----------------------------------------------------------------------------+module Hackage.Types where++import Distribution.Simple.Compiler (CompilerFlavor)+import Distribution.Simple.InstallDirs (InstallDirTemplates)+import Distribution.Package (PackageIdentifier)+import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.Version (Dependency)+import Distribution.Verbosity++-- | We re-use @GenericPackageDescription@ and use the @package-url@+-- field to store the tarball URL.+data PkgInfo = PkgInfo {+ pkgInfoId :: PackageIdentifier,+ pkgRepo :: Repo,+ pkgDesc :: GenericPackageDescription+ }+ deriving (Show)++data Action+ = FetchCmd+ | InstallCmd+ | CleanCmd+ | UpdateCmd+ | InfoCmd+ | HelpCmd+ | ListCmd+ deriving (Show,Eq)++data Option = OptCompilerFlavor CompilerFlavor+ | OptCompiler FilePath+ | OptHcPkg FilePath+ | OptConfigFile FilePath+ | OptCacheDir FilePath+ | OptPrefix FilePath+ | OptBinDir FilePath+ | OptLibDir FilePath+ | OptLibSubDir FilePath+ | OptLibExecDir FilePath+ | OptDataDir FilePath+ | OptDataSubDir FilePath+ | OptDocDir FilePath+ | OptHtmlDir FilePath+ | OptUserInstall Bool+ | OptHelp+ | OptVerbose Verbosity+ deriving (Eq,Show)++data ConfigFlags = ConfigFlags {+ configCompiler :: CompilerFlavor,+ configCompilerPath :: Maybe FilePath,+ configHcPkgPath :: Maybe FilePath,+ configUserInstallDirs :: InstallDirTemplates,+ configGlobalInstallDirs :: InstallDirTemplates,+ configCacheDir :: FilePath,+ configRepos :: [Repo], -- ^Available Hackage servers.+ configVerbose :: Verbosity,+ configUserInstall :: Bool -- ^--user-install flag+ }+ deriving (Show)++data Repo = Repo {+ repoName :: String,+ repoURL :: String+ }+ deriving (Show,Eq)++data ResolvedPackage = Installed Dependency PackageIdentifier+ | Available Dependency PkgInfo [String] [ResolvedPackage]+ | Unavailable Dependency+ deriving (Show)++fulfills :: ResolvedPackage -> Dependency+fulfills (Installed d _) = d+fulfills (Available d _ _ _) = d+fulfills (Unavailable d) = d++data UnresolvedDependency+ = UnresolvedDependency+ { dependency :: Dependency+ , depOptions :: [String]+ }+ deriving (Show)
+ Hackage/Update.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hackage.Update+-- Copyright : (c) David Himmelstrup 2005+-- License : BSD-like+--+-- Maintainer : lemmih@gmail.com+-- Stability : provisional+-- Portability : portable+--+--+-----------------------------------------------------------------------------+module Hackage.Update+ ( update+ ) where++import Hackage.Types+import Hackage.Fetch+import Hackage.Tar++import qualified Data.ByteString.Lazy.Char8 as BS+import System.FilePath (dropExtension)+import Text.Printf++-- | 'update' downloads the package list from all known servers+update :: ConfigFlags -> IO ()+update cfg = mapM_ (updateRepo cfg) (configRepos cfg)++updateRepo :: ConfigFlags + -> Repo+ -> IO ()+updateRepo cfg repo =+ do printf "Downloading package list from server '%s'\n" (repoURL repo)+ indexPath <- downloadIndex cfg repo+ BS.readFile indexPath >>= BS.writeFile (dropExtension indexPath) . gunzip
+ Hackage/Utils.hs view
@@ -0,0 +1,98 @@+module Hackage.Utils where++import Distribution.Compat.ReadP (ReadP, readP_to_S, pfail, get, look, choice, (+++))+import Distribution.Package (PackageIdentifier(..), parsePackageId)+import Distribution.ParseUtils + (Field(..), FieldDescr(..), ParseResult(..), PError+ , field, liftField, readFields+ , showDependency, parseDependency+ , warning, lineNo, locatedErrorMsg)+import Distribution.Version (Version(..), Dependency(..), VersionRange(..))++import Control.Exception+import Control.Monad (foldM, liftM, guard)+import Data.Char (isSpace, toLower)+import Data.List (intersperse)+import Data.Maybe (listToMaybe)+import System.IO.Error (isDoesNotExistError)+import Text.PrettyPrint.HughesPJ (Doc, render, vcat, text, (<>), (<+>))+++readFileIfExists :: FilePath -> IO (Maybe String)+readFileIfExists path = + catchJust fileNotFoundExceptions + (fmap Just (readFile path)) + (\_ -> return Nothing)++fileNotFoundExceptions :: Exception -> Maybe IOError+fileNotFoundExceptions e = + ioErrors e >>= \ioe -> guard (isDoesNotExistError ioe) >> return ioe+++showPError :: PError -> String+showPError err = let (ml,msg) = locatedErrorMsg err+ in maybe "" (\l -> "On line " ++ show l ++ ": ") ml ++ msg++++readPToMaybe :: ReadP r a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str, all isSpace s ]++ignoreWarnings :: ParseResult a -> ParseResult a+ignoreWarnings (ParseOk _ x) = ParseOk [] x+ignoreWarnings r = r ++parseBasicStanza :: [FieldDescr a] -> a -> String -> ParseResult a+parseBasicStanza fields empty inp = + readFields inp >>= foldM (setField fields) empty++setField :: [FieldDescr a]+ -> a+ -> Field+ -> ParseResult a+setField fs x (F line f val) =+ case lookupFieldDescr fs f of+ Nothing -> + do warning ("Unrecognized field " ++ f ++ " on line " ++ show line)+ return x+ Just (FieldDescr _ _ set) -> set line val x+setField _ x s = + do warning ("Unrecognized stanza on line " ++ show (lineNo s))+ return x++lookupFieldDescr :: [FieldDescr a] -> String -> Maybe (FieldDescr a)+lookupFieldDescr fs n = listToMaybe [f | f@(FieldDescr name _ _) <- fs, name == n]++boolField :: String -> (a -> Bool) -> (Bool -> a -> a) -> FieldDescr a+boolField name g s = liftField g s $ field name showBool readBool+ where+ showBool :: Bool -> Doc+ showBool True = text "true"+ showBool False = text "false"++ readBool :: ReadP r Bool+ readBool = choice [ stringNoCase "true" >> return True+ , stringNoCase "false" >> return False+ , stringNoCase "yes" >> return True+ , stringNoCase "no" >> return False]++showFields :: [FieldDescr a] -> a -> String+showFields fs x = render $ vcat [ text name <> text ":" <+> g x | FieldDescr name g _ <- fs]+++stringNoCase :: String -> ReadP r String+stringNoCase this = look >>= scan this+ where+ scan [] _ = return this+ scan (x:xs) (y:ys) | toLower x == toLower y = get >> scan xs ys+ scan _ _ = pfail+++showDependencies :: [Dependency] -> String+showDependencies = concat . intersperse ", " . map (show . showDependency)++parseDependencyOrPackageId :: ReadP r Dependency+parseDependencyOrPackageId = parseDependency +++ liftM pkgToDep parsePackageId+ where pkgToDep p = case pkgVersion p of+ Version [] _ -> Dependency (pkgName p) AnyVersion+ version -> Dependency (pkgName p) (ThisVersion version)
+ LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2003-2007, Isaac Jones, Simon Marlow, Martin Sjögren,+ Bjorn Bringert, Krasimir Angelov,+ Malcolm Wallace, Ross Patterson,+ Lemmih, Paolo Martini, Don Stewart+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.
+ Main.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- 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 where++import Hackage.Types (Action (..), Option(..))+import Hackage.Setup (parseGlobalArgs, parsePackageArgs, configFromOptions)+import Hackage.Config (defaultConfigFile, loadConfig, findCompiler+ , message, showConfig)+import Hackage.List (list)+import Hackage.Install (install)+import Hackage.Info (info)+import Hackage.Update (update)+import Hackage.Fetch (fetch)+import Hackage.Clean (clean)++import Distribution.Verbosity (verbose)++import System.Environment (getArgs)++-- | Entry point+--+main :: IO ()+main = do+ rawArgs <- getArgs+ (action, flags, args) <- parseGlobalArgs rawArgs+ configFile <- case [f | OptConfigFile f <- flags] of+ [] -> defaultConfigFile+ fs -> return (last fs)++ conf0 <- loadConfig configFile++ let config = configFromOptions conf0 flags++ message config verbose "Configuration:"+ message config verbose (showConfig config)++ let runCmd f = do (globalArgs, pkgs) <- parsePackageArgs action args+ (comp, conf) <- findCompiler config+ f config comp conf globalArgs pkgs++ case action of+ InstallCmd -> runCmd install+ InfoCmd -> runCmd info+ ListCmd -> list config args+ UpdateCmd -> update config+ CleanCmd -> clean config+ FetchCmd -> runCmd fetch+ _ -> error "Unhandled command."+
+ README view
@@ -0,0 +1,47 @@+== cabal install ==++The automatic package manager for Haskell!++Intended usage:++ cabal install xmonad++Just works. Defaults make sense, and by default we don't fail unless it+is unrecoverable.++== Dependences ==++ base >= 2.1, process, directory, pretty, bytestring >= 0.9+ mtl, network, regex-compat, unix, Cabal>=1.3,+ zlib >= 0.4, HTTP >= 3000.0 && < 3000.1, filepath >= 1.0++Kind of ironic we need cabal install to make it easier to build cabal+install. ++== Developer docs ==++ CabalInstall, what happens under the hood.++ FetchCmd:+ cabal-install stores packages in [config-dir]/packages/ by their package id.+ This can lead to clashes if there's two identical (same name, same version)+ packages from two servers with different functionality.+ CleanCmd:+ Removes all fetched packages.+ UpdateCmd:+ Queries all known servers for their packages and stores it in [cfg-dir]/pkg.list.+ InstallCmd:+ Installed packages are determined, and dependencies of the to-be-installed packages+ are resolved and fetched.+ The fetched tarballs are moved to a temporary directory (usually /tmp) and extracted.+ Distribution.Simple.SetupWrapper is used to configure, build and install the+ unpacked package. The user can+ only pass arguments to the 'configure' phase of the installation. '--user' is used+ by default.+ InfoCmd:+ To be written.++ Files used by cabal-install:+ [cfg-dir]/config configuration file+ [cfg-dir]/00-index.tar list of packages available from the servers.+ [cfg-dir]/packages/ directory containing all fetched packages.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ cabal-install.cabal view
@@ -0,0 +1,55 @@+Name: cabal-install+Version: 0.4.0+Synopsis: Automatic package handling for Haskell+Description: + apt-get like tool for Haskell. 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.+License: BSD3+License-File: LICENSE+Author: Lemmih <lemmih@gmail.com>, Paolo Martini <paolo@nemail.it>+Maintainer: cabal-devel@haskell.org+Copyright: 2005 Lemmih <lemmih@gmail.com>, 2006 Paolo Martini <paolo@nemail.it>+Stability: Experimental+Category: Distribution+Build-type: Simple+Extra-Source-Files: README+Cabal-Version: >= 1.2++flag old-base+ description: Old, monolithic base+ default: False++flag bytestring-in-base++Executable cabal+ Main-Is: Main.hs+ Ghc-Options: -Wall+ Other-Modules:+ Hackage.Clean+ Hackage.Config+ Hackage.Dependency+ Hackage.Fetch+ Hackage.Index+ Hackage.Info+ Hackage.Install+ Hackage.List+ Hackage.Setup+ Hackage.Tar+ Hackage.Types+ Hackage.Update+ Hackage.Utils++ build-depends: Cabal >= 1.2, filepath >= 1.0, network,+ zlib >= 0.3, HTTP >= 3000.0 && < 3001.1++ if flag(old-base)+ build-depends: base < 3+ else+ build-depends: base >= 3, process, directory, pretty++ if flag(bytestring-in-base)+ build-depends: base >= 2.0 && < 2.2+ else+ build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9