Commit 83a586de authored by bjorn@bringert.net's avatar bjorn@bringert.net
Browse files

Imported all the cabal-install sources.

parent 264c3811
module Main where
import qualified Network.Hackage.CabalInstall.Main as CabalInstall
main :: IO ()
main = CabalInstall.main
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.BuildDep
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- High level interface to a specialized instance of package installation.
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.BuildDep where
import Network.Hackage.CabalInstall.Dependency (getPackages, getBuildDeps, resolveDependenciesAux)
import Network.Hackage.CabalInstall.Install (installPkg)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), UnresolvedDependency)
import Distribution.Simple.Configure (getInstalledPackages)
{-|
This function behaves exactly like 'Network.Hackage.CabalInstall.Install.install' except
that it only builds the dependencies for packages.
-}
buildDep :: ConfigFlags -> [String] -> [UnresolvedDependency] -> IO ()
buildDep cfg globalArgs deps
= do ipkgs <- getInstalledPackages (configCompiler cfg) (configUserIns cfg) (configVerbose cfg)
apkgs <- fmap getPackages (fmap (getBuildDeps ipkgs) (resolveDependenciesAux cfg ipkgs deps))
mapM_ (installPkg cfg globalArgs) apkgs
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.Clean
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
--
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Clean
( clean
) where
import Network.Hackage.CabalInstall.Types (ConfigFlags)
import Network.Hackage.CabalInstall.Fetch (packagesDirectory)
import System.Directory (removeDirectoryRecursive)
-- | 'clean' removes all downloaded packages from the {config-dir}\/packages\/ directory.
clean :: ConfigFlags -> IO ()
clean cfg
= removeDirectoryRecursive (packagesDirectory cfg)
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.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 Network.Hackage.CabalInstall.Config
( packagesDirectoryName
, getKnownServers
, getKnownPackages
, writeKnownPackages
, selectValidConfigDir
) where
import Prelude hiding (catch)
import Control.Exception (catch, Exception(IOException))
import Control.Monad.Error (mplus, filterM) -- Using Control.Monad.Error to get the Error instance for IO.
import System.Directory (Permissions (..), getPermissions)
import System.IO.Error (isDoesNotExistError)
import System.IO (hPutStrLn, stderr)
import Distribution.Package (PackageIdentifier)
import Distribution.Version (Dependency)
import Distribution.Compat.FilePath (joinFileName)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), PkgInfo (..))
pkgListFile :: FilePath
pkgListFile = "pkg.list"
servListFile :: FilePath
servListFile = "serv.list"
-- |Name of the packages directory.
packagesDirectoryName :: FilePath
packagesDirectoryName = "packages"
pkgList :: ConfigFlags -> FilePath
pkgList cfg = configConfPath cfg `joinFileName` pkgListFile
servList :: ConfigFlags -> FilePath
servList cfg = configConfPath cfg `joinFileName` servListFile
-- |Read the list of known packages from the pkg.list file.
getKnownPackages :: ConfigFlags -> IO [PkgInfo]
getKnownPackages cfg
= fmap read (readFile (pkgList cfg))
`catch` (\e
-> do hPutStrLn stderr ("Warning: Problem opening package list '"
++ pkgList cfg
++ "'."
)
case e of
IOException ioe | isDoesNotExistError ioe ->
hPutStrLn stderr "File doesn't exist. Run 'cabal-install update' to create the package list."
_ -> hPutStrLn stderr ("Error: " ++ (show e))
return [])
-- |Write the list of known packages to the pkg.list file.
writeKnownPackages :: ConfigFlags -> [PkgInfo] -> IO ()
writeKnownPackages cfg pkgs
= writeFile (pkgList cfg) (show pkgs)
getKnownServers :: ConfigFlags -> IO [String]
getKnownServers cfg
= fmap read (readFile (servList cfg))
`mplus` return []
-- |Confirms validity of a config directory by checking the permissions for the package-list file,
-- server-list file and downloaded packages directory.
isValidConfigDir :: FilePath -> IO Bool
isValidConfigDir path
= do checks <- sequence
[ checkFiles readable [ path
, path `joinFileName` servListFile ]]
return (and checks)
-- |Picks the first valid config directory or throws an exception if none were found.
selectValidConfigDir :: [FilePath] -> IO FilePath
selectValidConfigDir paths
= do valids <- filterM isValidConfigDir paths
case valids of
[] -> error "No valid config dir found!"
(x:_) -> return x
checkFiles :: (Permissions -> Bool) -> [FilePath] -> IO Bool
checkFiles check
= worker True
where worker r [] = return r
worker r (x:xs)
= do permissions <- getPermissions x
if check permissions
then worker r xs
else return False
`mplus` worker False xs
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.Configure
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Functions used to generate ConfigFlags.
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Configure
( defaultOutputGen
, mkConfigFlags
) where
import Control.Monad (guard, mplus, when)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen (..)
, TempFlags (..), ResolvedPackage (..))
import Network.Hackage.CabalInstall.Config (getKnownServers, selectValidConfigDir)
import qualified Distribution.Simple.Configure as Configure (findProgram, configCompiler)
import Distribution.ParseUtils (showDependency)
import Distribution.Package (showPackageId)
import Distribution.Compat.FilePath (joinFileName)
import Text.Printf (printf)
import System.IO (openFile, IOMode (..))
import System.Directory (getHomeDirectory, getAppUserDataDirectory)
import Data.Maybe (fromMaybe)
{-|
Structure with default responses to various events.
-}
defaultOutputGen :: Int -> IO OutputGen
defaultOutputGen verbose
= do (outch,errch) <- do guard (verbose <= 1)
nullOut <- openFile "/dev/null" AppendMode
nullErr <- openFile "/dev/null" AppendMode
return (Just nullOut, Just nullErr)
`mplus` return (Nothing,Nothing)
return OutputGen
{ prepareInstall = \_pkgs -> return ()
, pkgIsPresent = printf "'%s' is present.\n" . showPackageId
, downloadingPkg = printf "Downloading '%s'\n" . showPackageId
, executingCmd = \cmd args
-> when (verbose > 0) $ printf "Executing: '%s %s'\n" cmd (unwords args)
, cmdFailed = \cmd args errno
-> error (printf "Command failed: '%s %s'. Errno: %d\n" cmd (unwords args) errno)
, buildingPkg = printf "Building '%s'\n" . showPackageId
, stepConfigPkg = const (printf " Configuring...\n")
, stepBuildPkg = const (printf " Building...\n")
, stepInstallPkg = const (printf " Installing...\n")
, stepFinishedPkg= const (printf " Done.\n")
, noSetupScript = const (error "Couldn't find a setup script in the tarball.")
, noCabalFile = const (error "Couldn't find a .cabal file in the tarball")
, gettingPkgList = \serv ->
when (verbose > 0) (printf "Downloading package list from server '%s'\n" serv)
, showPackageInfo = showPkgInfo
, showOtherPackageInfo = showOtherPkg
, cmdStdout = outch
, cmdStderr = errch
}
where showOtherPkg mbPkg dep
= do printf " Package: '%s'\n" (show $ showDependency dep)
case mbPkg of
Nothing -> printf " Not available!\n\n"
Just pkg -> do printf " Using: %s\n" (showPackageId pkg)
printf " Installed: Yes\n\n"
showPkgInfo mbPath installed ops dep (pkg,location,deps)
= do printf " Package: '%s'\n" (show $ showDependency dep)
printf " Using: %s\n" (showPackageId pkg)
printf " Installed: %s\n" (if installed then "Yes" else "No")
printf " Depends: %s\n" (showDeps deps)
printf " Options: %s\n" (unwords ops)
printf " Location: %s\n" location
printf " Local: %s\n\n" (fromMaybe "*Not downloaded" mbPath)
showDeps = show . map showDep
showDep dep = show (showDependency (fulfilling dep))
findProgramOrDie :: String -> Maybe FilePath -> IO FilePath
findProgramOrDie name p = fmap (fromMaybe (error $ printf "No %s found." name)) (Configure.findProgram name p)
-- |Compute the default prefix when doing a local install ('~/usr' on Linux).
localPrefix :: IO FilePath
localPrefix
= do home <- getHomeDirectory
return (home `joinFileName` "usr")
-- |Compute the local config directory ('~/.cabal-install' on Linux).
localConfigDir :: IO FilePath
localConfigDir
= getAppUserDataDirectory "cabal-install"
{-|
Give concrete answers to questions like:
* where to find \'runhaskell\'.
* where to find \'tar\'.
* which compiler to use.
* which config-directory to use.
-}
mkConfigFlags :: TempFlags -> IO ConfigFlags
mkConfigFlags cfg
= do runHc <- findProgramOrDie "runhaskell" (tempRunHc cfg)
tarProg <- findProgramOrDie "tar" (tempTarPath cfg)
comp <- Configure.configCompiler (tempHcFlavor cfg) (tempHcPath cfg) (tempHcPkg cfg) (tempVerbose cfg)
localConfig <- localConfigDir
prefix <- if tempUserIns cfg || tempUser cfg
then fmap Just (maybe localPrefix return (tempPrefix cfg))
else return Nothing
confPath <- selectValidConfigDir ( maybe id (:) (tempConfPath cfg)
["/etc/cabal-install"
,localConfig] )
when (tempVerbose cfg > 0) $ printf "Using config dir: %s\n" confPath
outputGen <- defaultOutputGen (tempVerbose cfg)
let config = ConfigFlags
{ configCompiler = comp
, configConfPath = confPath
, configPrefix = prefix
, configServers = []
, configTarPath = tarProg
, configRunHc = runHc
, configOutputGen = outputGen
, configVerbose = tempVerbose cfg
-- , configUpgradeDeps = tempUpgradeDeps cfg
, configUserIns = tempUserIns cfg || tempUser cfg
}
knownServers <- getKnownServers config
return (config{ configServers = knownServers ++ tempServers cfg})
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.Dependency
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- Various kinds of dependency resolution and utilities.
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Dependency
(
-- * Dependency resolution
resolveDependencies
, resolveDependenciesAux
-- * Utilities
, getPackages -- :: [ResolvedPackage] -> [(PackageIdentifier,[String],String)]
, getBuildDeps -- :: [PackageIdentifier] -> [ResolvedPackage] -> [ResolvedPackage]
, filterFetchables -- :: [ResolvedPackage] -> [(PackageIdentifier,String)]
, fulfillDependency -- :: Dependency -> PackageIdentifier -> Bool
) where
import Distribution.Version (Dependency(..), withinRange)
import Distribution.Package (PackageIdentifier(..))
import Distribution.ParseUtils (showDependency)
import Data.List (nub, maximumBy)
import Data.Maybe (mapMaybe)
import Control.Monad (guard)
import Network.Hackage.CabalInstall.Config (getKnownPackages)
import Network.Hackage.CabalInstall.Types ( ResolvedPackage(..), UnresolvedDependency(..)
, ConfigFlags (..), PkgInfo (..), ResolvedDependency(..))
import Text.Printf (printf)
-- |Flattens a list of dependencies, filtering out installed packages.
-- Packages dependencies are placed before the packages and duplicate entries
-- are removed.
flattenDepList :: [PackageIdentifier] -- ^List of installed packages.
-> [ResolvedPackage] -- ^List of resolved packages.
-> [ResolvedPackage]
flattenDepList ps deps
= nub $ worker deps
where isBeingInstalled dep
= not . null $ flip mapMaybe deps $ \rpkg -> do (pkg,_,_) <- resolvedData rpkg
guard (fulfillDependency dep pkg)
worker [] = []
worker (pkgInfo:xs)
= case getLatestPkg ps (fulfilling pkgInfo) of
Just _pkg -> worker xs
Nothing
-> case resolvedData pkgInfo of
Just (_pkg,_location,subDeps)
-> worker (filter (not.isBeingInstalled.fulfilling) subDeps) ++ pkgInfo:worker xs
Nothing
-> pkgInfo:worker xs
-- |Flattens a dependency list while only keeping the dependencies of the packages.
-- This is used for installing all the dependencies of a package but not the package itself.
getBuildDeps :: [PackageIdentifier] -> [ResolvedPackage]
-> [ResolvedPackage]
getBuildDeps ps deps
= nub $ concatMap worker deps
where worker pkgInfo
= case getLatestPkg ps (fulfilling pkgInfo) of
Just _pkg -> []
Nothing -> case resolvedData pkgInfo of
Just (_pkg,_location,subDeps)
-> flattenDepList ps subDeps
Nothing -> []
{-
getReverseDeps :: [PackageIdentifier] -- All installed packages.
-> [(PackageIdentifier,[Dependency],String)] -- Known packages.
-> [(PackageIdentifier,[Dependency],String)] -- Resolved and installed packages.
-> [(PackageIdentifier,[String],String)] -- Packages to be installed.
-> [(PackageIdentifier,[String],String)]
getReverseDeps ps knownPkgs ipkgs toBeInstalled
= nub $ concatMap resolve $ filter depends ipkgs
where depends (_pkg,deps,_location)
= or (map (\dep -> or (map (\(p,_,_) -> fulfillDependency dep p) toBeInstalled)) deps)
resolve (pkg,deps,location)
= let resolveDep dep
= case find (\(p,_,_) -> fulfillDependency dep p) knownPkgs of
Just (pkg,_,location) -> Just (pkg,[],location)
Nothing
| pkg `elem` ps -> Nothing
| otherwise -> error "Urk!"
in mapMaybe resolveDep deps ++ [(pkg,[],location)]
-- |Find the dependencies and location for installed packages.
-- Packages not located on a Hackage server will be filtered out.
filterInstalledPkgs :: [PackageIdentifier] -> [(PackageIdentifier,[Dependency],String)]
-> [(PackageIdentifier,[Dependency],String)]
filterInstalledPkgs ipkgs knownPkgs
= filter worker knownPkgs
where worker (pkg,_deps,_location)
= pkg `elem` ipkgs
-}
depToUnresolvedDep :: Dependency -> UnresolvedDependency
depToUnresolvedDep dep
= UnresolvedDependency
{ dependency = dep
, depOptions = [] }
resolvedDepToResolvedPkg :: (Dependency,Maybe ResolvedDependency) -> ResolvedPackage
resolvedDepToResolvedPkg (dep,rDep)
= ResolvedPackage
{ fulfilling = dep
, resolvedData = rData
, pkgOptions = [] }
where rData = do ResolvedDependency pkg location subDeps <- rDep
return ( pkg
, location
, map resolvedDepToResolvedPkg subDeps )
-- |Locates a @PackageIdentifier@ which satisfies a given @Dependency@.
-- Fails with "cannot satisfy dependency: %s." where %s == the given dependency.
getLatestPkg :: (Monad m) => [PackageIdentifier] -> Dependency -> m PackageIdentifier
getLatestPkg ps dep
= case filter (fulfillDependency dep) ps of
[] -> fail $ printf "cannot satisfy dependency: %s." (show (showDependency dep))
qs -> let pkg = maximumBy versions qs
versions a b = pkgVersion a `compare` pkgVersion b
in return pkg
-- |Evaluates to @True@ if the given @Dependency@ is satisfied by the given @PackageIdentifer@.
fulfillDependency :: Dependency -> PackageIdentifier -> Bool
fulfillDependency (Dependency depName vrange) pkg
= pkgName pkg == depName && pkgVersion pkg `withinRange` vrange
getDependency :: [PkgInfo]
-> UnresolvedDependency -> ResolvedPackage
getDependency ps (UnresolvedDependency { dependency=dep@(Dependency pkgname vrange)
, depOptions=opts})
= case filter ok ps of
[] -> ResolvedPackage
{ fulfilling = dep
, resolvedData = Nothing
, pkgOptions = opts }
qs -> let PkgInfo { infoId = pkg, infoDeps = deps, infoURL = location } = maximumBy versions qs
versions a b = pkgVersion (infoId a) `compare` pkgVersion (infoId b)
in ResolvedPackage
{ fulfilling = dep
, resolvedData = Just ( pkg
, location
, (map (getDependency ps) (map depToUnresolvedDep deps)))
, pkgOptions = opts }
where ok PkgInfo{ infoId = p } = pkgName p == pkgname && pkgVersion p `withinRange` vrange
-- |Get the PackageIdentifier, build options and location from a list of resolved packages.
-- Throws an exception if a package couldn't be resolved.
getPackages :: [ResolvedPackage] -> [(PackageIdentifier,[String],String)]
getPackages = map worker
where worker dep
= case resolvedData dep of
Nothing
-> error $ printf "Couldn't satisfy dependency: '%s'." (show $ showDependency (fulfilling dep))
Just (pkg,location,_)
-> (pkg,pkgOptions dep,location)
-- |List all packages which can be fetched.
filterFetchables :: [ResolvedPackage] -> [(PackageIdentifier,String)]
filterFetchables = mapMaybe worker
where worker dep = do (pkg,location,_) <- resolvedData dep
return (pkg,location)
-- |Resolve some dependencies from the known packages while filtering out installed packages.
-- The result hasn't been modified to put the dependencies in front of the packages.
resolveDependenciesAux :: ConfigFlags
-> [PackageIdentifier] -- ^Installed packages.
-> [UnresolvedDependency] -- ^Dependencies in need of resolution.
-> IO [ResolvedPackage]
resolveDependenciesAux cfg ps deps
= do knownPkgs <- getKnownPackages cfg
let resolved = map (resolve knownPkgs) (filter isNotInstalled deps)
return resolved
where isNotInstalled pkgDep = not (or (map (fulfillDependency (dependency pkgDep)) ps))
resolve pkgs dep
= let rDep = getDependency pkgs dep
in case resolvedData rDep of
Nothing -> resolvedDepToResolvedPkg (dependency dep,Nothing)
_ -> rDep
-- |Resolve some dependencies from the known packages while filtering out installed packages.
-- The result has been modified to put the dependencies in front of the packages.
resolveDependencies :: ConfigFlags
-> [PackageIdentifier] -- ^Installed packages.
-> [UnresolvedDependency] -- ^Dependencies in need of resolution.
-> IO [ResolvedPackage]
resolveDependencies cfg ps deps
= fmap (flattenDepList ps) (resolveDependenciesAux cfg ps deps)
-----------------------------------------------------------------------------
-- |
-- Module : Network.Hackage.CabalInstall.Fetch
-- Copyright : (c) David Himmelstrup 2005
-- License : BSD-like
--
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
--
--
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Fetch
(
-- * Commands
fetch
, -- * Utilities
fetchPackage
, packageFile
, packagesDirectory
, isFetched
, readURI
, downloadIndex
) where
import Network.URI (URI,parseURI,uriScheme,uriPath)
import Network.HTTP (ConnError(..), Request (..), simpleHTTP
, Response(..), RequestMethod (..))
import Control.Monad (filterM)
import Text.Printf (printf)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen (..), UnresolvedDependency (..))
import Network.Hackage.CabalInstall.Config (packagesDirectoryName)
import Network.Hackage.CabalInstall.Dependency (filterFetchables, resolveDependencies)
import Distribution.Package (PackageIdentifier, showPackageId)
import Distribution.Compat.FilePath (joinFileName, joinFileExt)
import System.Directory (copyFile)
import Text.ParserCombinators.ReadP (readP_to_S)
import Distribution.ParseUtils (parseDependency)
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) -> writeFile path (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)