Commit 5954e871 authored by audreyt@audreyt.org's avatar audreyt@audreyt.org
Browse files

stage 2 patch: implement the "list" command

parent 76a19292
......@@ -25,7 +25,7 @@ import Distribution.Package (PackageIdentifier)
import Distribution.Version (Dependency)
import Distribution.Compat.FilePath (joinFileName)
import Network.Hackage.CabalInstall.Types (ConfigFlags (..))
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), PkgInfo (..))
pkgListFile :: FilePath
pkgListFile = "pkg.list"
......@@ -44,13 +44,13 @@ servList :: ConfigFlags -> FilePath
servList cfg = configConfPath cfg `joinFileName` servListFile
-- |Read the list of known packages from the pkg.list file.
getKnownPackages :: ConfigFlags -> IO [(PackageIdentifier,[Dependency],String)]
getKnownPackages :: ConfigFlags -> IO [PkgInfo]
getKnownPackages cfg
= fmap read (readFile (pkgList cfg))
`mplus` return []
-- |Write the list of known packages to the pkg.list file.
writeKnownPackages :: ConfigFlags -> [(PackageIdentifier,[Dependency],String)] -> IO ()
writeKnownPackages :: ConfigFlags -> [PkgInfo] -> IO ()
writeKnownPackages cfg pkgs
= writeFile (pkgList cfg) (show pkgs)
......
......@@ -120,7 +120,7 @@ mkConfigFlags cfg
confPath <- selectValidConfigDir ( maybe id (:) (tempConfPath cfg)
["/etc/cabal-install"
,localConfig] )
printf "Using config dir: %s\n" confPath
when (tempVerbose cfg > 0) $ printf "Using config dir: %s\n" confPath
outputGen <- defaultOutputGen (tempVerbose cfg)
let config = ConfigFlags
{ configCompiler = comp
......
......@@ -33,7 +33,7 @@ import Control.Monad (guard)
import Network.Hackage.CabalInstall.Config (getKnownPackages)
import Network.Hackage.CabalInstall.Types ( ResolvedPackage(..), UnresolvedDependency(..)
, ConfigFlags (..))
, ConfigFlags (..), PkgInfo (..))
import Text.Printf (printf)
......@@ -135,7 +135,7 @@ fulfillDependency :: Dependency -> PackageIdentifier -> Bool
fulfillDependency (Dependency depName vrange) pkg
= pkgName pkg == depName && pkgVersion pkg `withinRange` vrange
getDependency :: [(PackageIdentifier,[Dependency],String)]
getDependency :: [PkgInfo]
-> UnresolvedDependency -> ResolvedPackage
getDependency ps (UnresolvedDependency { dependency=dep@(Dependency pkgname vrange)
, depOptions=opts})
......@@ -144,15 +144,15 @@ getDependency ps (UnresolvedDependency { dependency=dep@(Dependency pkgname vran
{ fulfilling = dep
, resolvedData = Nothing
, pkgOptions = opts }
qs -> let (pkg,deps,location) = maximumBy versions qs
versions (a,_,_) (b,_,_) = pkgVersion a `compare` pkgVersion b
qs -> let PkgInfo pkg deps 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 (p,_,_) = pkgName p == pkgname && pkgVersion p `withinRange` vrange
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.
......
......@@ -12,135 +12,33 @@
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.List
( list -- :: ConfigFlags -> [UnresolvedDependency] -> IO ()
, installPkg -- :: ConfigFlags -> (PackageIdentifier,[String],String) -> IO ()
) where
import Control.Exception (bracket_)
import Network.Hackage.CabalInstall.Dependency (getPackages, resolveDependencies)
import Network.Hackage.CabalInstall.Fetch (isFetched, packageFile, fetchPackage)
import Network.Hackage.CabalInstall.Types (ConfigFlags(..), UnresolvedDependency(..)
import Text.Regex
import Data.Maybe (catMaybes, isJust)
import Data.List (find, nub)
import Distribution.Package
import Distribution.PackageDescription
import Network.Hackage.CabalInstall.Config (getKnownPackages)
import Network.Hackage.CabalInstall.Types (PkgInfo(..), ConfigFlags(..), UnresolvedDependency(..)
,OutputGen(..))
import Network.Hackage.CabalInstall.TarUtils
import Distribution.Simple.Configure (getInstalledPackages)
import Distribution.Package (showPackageId, PackageIdentifier)
import Distribution.Compat.FilePath (joinFileName, splitFileName)
import Text.Printf (printf)
import System.Directory (getTemporaryDirectory, createDirectoryIfMissing
,removeDirectoryRecursive, copyFile)
import System.Process (runProcess, waitForProcess, terminateProcess)
import System.Exit (ExitCode(..))
import System.Posix.Signals
-- |Installs the packages needed to satisfy a list of dependencies.
list :: ConfigFlags -> [String] -> [UnresolvedDependency] -> IO ()
list cfg globalArgs deps
= do ipkgs <- getInstalledPackages (configCompiler cfg) (configUser cfg) (configVerbose cfg)
apkgs <- fmap getPackages (resolveDependencies cfg ipkgs deps)
mapM_ (installPkg cfg globalArgs) apkgs
-- Fetch a package and output nice messages.
downloadPkg :: ConfigFlags -> PackageIdentifier -> String -> IO FilePath
downloadPkg cfg pkg location
= do fetched <- isFetched cfg pkg
if fetched
then do pkgIsPresent (configOutputGen cfg) pkg
return (packageFile cfg pkg)
else do downloadingPkg (configOutputGen cfg) pkg
fetchPackage cfg pkg location
whenFlag :: Bool -> String -> [String] -> [String]
whenFlag True = (:)
whenFlag False = flip const
-- Attach the correct prefix flag to configure commands,
-- correct --user flag to install commands and no options to other commands.
mkPkgOps :: ConfigFlags -> String -> [String] -> [String]
mkPkgOps cfg "configure" ops
= let ops' = whenFlag (configUser cfg) "--user" ops
in maybe id (\p -> (:) ("--prefix="++p)) (configPrefix cfg) ops'
mkPkgOps cfg "install" _ops
| configUserIns cfg = return "--user"
mkPkgOps _cfg _ _ops
= []
{-|
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.
* The lowest directory with a .cabal file is located and searched for a \'Setup.lhs\' or
\'Setup.hs\' file.
* \'runhaskell [Setup script] configure\' is called with the user specified options, \'--user\'
if the 'configUser' flag is @True@ and \'--prefix=[PREFIX]\' if 'configPrefix' is not @Nothing@.
* \'runhaskell [Setup script] build\' is called with no options.
* \'runhaskell [Setup script] install\' is called with the \'--user\' flag if 'configUserIns' is @True@.
* The installation finishes by deleting the unpacked tarball.
-}
installPkg :: ConfigFlags
-> [String] -- ^Options which will be parse to every package.
-> (PackageIdentifier,[String],String) -- ^(Package, list of configure options, package location)
-> IO ()
installPkg cfg globalArgs (pkg,ops,location)
= do pkgPath <- downloadPkg cfg pkg location
tmp <- getTemporaryDirectory
let tmpDirPath = tmp `joinFileName` printf "TMP%sTMP" (showPackageId pkg)
tmpPkgPath = tmpDirPath `joinFileName` printf "TAR%s.tgz" (showPackageId pkg)
setup setupScript cmd
= let (path,script) = splitFileName setupScript
cmdOps = mkPkgOps cfg cmd (globalArgs++ops)
in do executingCmd output runHc (script:cmd:cmdOps)
h <- runProcess runHc (script:cmd:cmdOps)
(Just (tmpDirPath `joinFileName` path))
Nothing Nothing (cmdStdout output) (cmdStderr output)
oldHandler <- installHandler keyboardSignal (Catch (terminateProcess h)) Nothing
e <- waitForProcess h
installHandler keyboardSignal oldHandler Nothing
case e of
ExitFailure err -> cmdFailed output cmd (script:cmd:cmdOps) err
_ -> return ()
bracket_ (createDirectoryIfMissing True tmpDirPath)
(removeDirectoryRecursive tmpDirPath)
(do copyFile pkgPath tmpPkgPath
extractTarFile tarProg tmpPkgPath
installUnpackedPkg cfg pkg tmpPkgPath setup
return ())
where runHc = configRunHc cfg
tarProg = configTarPath cfg
output = configOutputGen cfg
installUnpackedPkg :: ConfigFlags -> PackageIdentifier -> FilePath
-> (String -> String -> IO ()) -> IO ()
installUnpackedPkg cfg pkgId tarFile setup
= do tarFiles <- tarballGetFiles tarProg tarFile
let cabalFile = locateFileExt tarFiles "cabal"
case cabalFile of
Just f -> let (path,_) = splitFileName f
mbScript = locateFile tarFiles path ["Setup.lhs", "Setup.hs"]
in case mbScript of
Just script
-> do buildingPkg output pkgId
stepConfigPkg output pkgId
setup script "configure"
stepBuildPkg output pkgId
setup script "build"
stepInstallPkg output pkgId
setup script "install"
stepFinishedPkg output pkgId
return ()
Nothing
-> noSetupScript output pkgId
Nothing -> noCabalFile output pkgId
where output = configOutputGen cfg
tarProg = configTarPath cfg
-- |Show information about packages
list :: ConfigFlags -> [String] -> IO ()
list cfg pats = do
pkgs <- getKnownPackages cfg
mapM_ doList $ if null pats then pkgs else nub (concatMap (findInPkgs pkgs) pats)
where
findInPkgs :: [PkgInfo] -> String -> [PkgInfo]
findInPkgs pkgs pat = let rx = mkRegexWithOpts pat False False in
filter (isJust . matchRegex rx . showInfo) pkgs
showInfo :: PkgInfo -> String
showInfo pkg = showPackageId (infoId pkg) ++ "\n" ++ infoSynopsis pkg
doList :: PkgInfo -> IO ()
doList info = do
putStr . (if null syn then id else padTo 25) . showPackageId . infoId $ info
putStrLn syn
where
syn = infoSynopsis info
padTo n s = s ++ (replicate (n - length s) ' ')
......@@ -33,10 +33,10 @@ main = do args <- getArgs
let runCmd f = do (globalArgs, pkgs) <- parseInstallArgs args
f config globalArgs pkgs
case action of
ListCmd -> runCmd list
InstallCmd -> runCmd install
BuildDepCmd -> runCmd buildDep
InfoCmd -> runCmd info
ListCmd -> list config args
UpdateCmd -> update config
CleanCmd -> clean config
FetchCmd -> fetch config args
......
......@@ -88,7 +88,7 @@ data Cmd = Cmd {
commandList :: [Cmd]
commandList = [fetchCmd, installCmd, buildDepCmd, updateCmd, cleanCmd, infoCmd]
commandList = [fetchCmd, installCmd, buildDepCmd, updateCmd, cleanCmd, listCmd, infoCmd]
lookupCommand :: String -> [Cmd] -> Maybe Cmd
lookupCommand name = find ((==name) . cmdName)
......@@ -171,6 +171,9 @@ fetchCmd = mkCmd "fetch" "Downloads packages for later installation or study." "
installCmd :: Cmd
installCmd = mkCmd "install" "Installs a list of packages." "" InstallCmd
listCmd :: Cmd
listCmd = mkCmd "list" "List available packages on the server." "" ListCmd
buildDepCmd :: Cmd
buildDepCmd = mkCmd "build-dep" "Installs the dependencies for a list of packages." "" BuildDepCmd
......
......@@ -18,6 +18,14 @@ import Distribution.Version (Dependency)
import System.IO (Handle)
data PkgInfo = PkgInfo
{ infoId :: PackageIdentifier
, infoDeps :: [Dependency]
, infoSynopsis :: String
, infoURL :: String
}
deriving (Show, Read, Eq)
data Action
= FetchCmd
| InstallCmd
......
......@@ -7,6 +7,7 @@ import Data.Version
import Data.Maybe
import Text.ParserCombinators.ReadP
import Distribution.ParseUtils
import Network.Hackage.CabalInstall.Types
type PathName = String
......@@ -28,14 +29,19 @@ getPkgDescriptions url pkgIds = mapM (getPkgDescription url) pkgIds
getDependencies :: String -> [Dependency] -> IO [(Dependency, Maybe ResolvedDependency)]
getDependencies _ _ = fail "getDependencies unimplemented" -- remote url "getDependencies"
listPackages :: String -> IO [(PackageIdentifier,[Dependency],String)]
listPackages :: String -> IO [PkgInfo]
listPackages url = do
x <- getFrom url "00-latest.txt" -- remote url "listPackages"
pkgs <- readIO x
return $ map parsePkg pkgs
where
parsePkg :: Pkg -> (PackageIdentifier,[Dependency],String)
parsePkg (Pkg ident deps _) = (pkgId, pkgDeps, pkgURL)
parsePkg :: Pkg -> PkgInfo
parsePkg (Pkg ident deps pkgSynopsis) = PkgInfo
{ infoId = pkgId
, infoDeps = pkgDeps
, infoSynopsis = pkgSynopsis
, infoURL = pkgURL
}
where
pkgId = parseWith parsePackageId ident
pkgDeps = map (parseWith parseDependency) deps
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment