diff --git a/Hackage/Clean.hs b/Hackage/Clean.hs new file mode 100644 --- /dev/null +++ b/Hackage/Clean.hs @@ -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 ())) diff --git a/Hackage/Config.hs b/Hackage/Config.hs new file mode 100644 --- /dev/null +++ b/Hackage/Config.hs @@ -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 } + diff --git a/Hackage/Dependency.hs b/Hackage/Dependency.hs new file mode 100644 --- /dev/null +++ b/Hackage/Dependency.hs @@ -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] + diff --git a/Hackage/Fetch.hs b/Hackage/Fetch.hs new file mode 100644 --- /dev/null +++ b/Hackage/Fetch.hs @@ -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 diff --git a/Hackage/Index.hs b/Hackage/Index.hs new file mode 100644 --- /dev/null +++ b/Hackage/Index.hs @@ -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 [] diff --git a/Hackage/Info.hs b/Hackage/Info.hs new file mode 100644 --- /dev/null +++ b/Hackage/Info.hs @@ -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" diff --git a/Hackage/Install.hs b/Hackage/Install.hs new file mode 100644 --- /dev/null +++ b/Hackage/Install.hs @@ -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 diff --git a/Hackage/List.hs b/Hackage/List.hs new file mode 100644 --- /dev/null +++ b/Hackage/List.hs @@ -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) diff --git a/Hackage/Setup.hs b/Hackage/Setup.hs new file mode 100644 --- /dev/null +++ b/Hackage/Setup.hs @@ -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 + diff --git a/Hackage/Tar.hs b/Hackage/Tar.hs new file mode 100644 --- /dev/null +++ b/Hackage/Tar.hs @@ -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 diff --git a/Hackage/Types.hs b/Hackage/Types.hs new file mode 100644 --- /dev/null +++ b/Hackage/Types.hs @@ -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) diff --git a/Hackage/Update.hs b/Hackage/Update.hs new file mode 100644 --- /dev/null +++ b/Hackage/Update.hs @@ -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 diff --git a/Hackage/Utils.hs b/Hackage/Utils.hs new file mode 100644 --- /dev/null +++ b/Hackage/Utils.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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." + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/cabal-install.cabal b/cabal-install.cabal new file mode 100644 --- /dev/null +++ b/cabal-install.cabal @@ -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 , Paolo Martini +Maintainer: cabal-devel@haskell.org +Copyright: 2005 Lemmih , 2006 Paolo Martini +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