diff --git a/Network/Hackage/CabalInstall/Fetch.hs b/Network/Hackage/CabalInstall/Fetch.hs
index 3256716e8811fe97471eb4a1494e7aee74379f7e..ab4292803a82acd8fd71434cbc388e13146518d8 100644
--- a/Network/Hackage/CabalInstall/Fetch.hs
+++ b/Network/Hackage/CabalInstall/Fetch.hs
@@ -21,7 +21,7 @@ module Network.Hackage.CabalInstall.Fetch
, isFetched
) where
-import Network.URI (URI,parseURI)
+import Network.URI (URI,parseURI,uriScheme,uriPath)
import Network.HTTP (ConnError(..), Request (..), simpleHTTP
, Response(..), RequestMethod (..))
@@ -35,6 +35,7 @@ import Network.Hackage.CabalInstall.Dependency (filterFetchables, resolveDepende
import Distribution.Package (PackageIdentifier, showPackageId)
import Distribution.Compat.FilePath (joinFileName)
+import System.Directory (copyFile)
import Text.ParserCombinators.ReadP (readP_to_S)
import Distribution.ParseUtils (parseDependency)
@@ -42,6 +43,9 @@ import Distribution.ParseUtils (parseDependency)
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
downloadURI path uri
= do eitherResult <- simpleHTTP request
case eitherResult of
diff --git a/Network/Hackage/CabalInstall/List.hs b/Network/Hackage/CabalInstall/List.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f88ddded8f828f439097cb059d3205a23e65d0f1
--- /dev/null
+++ b/Network/Hackage/CabalInstall/List.hs
@@ -0,0 +1,146 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.Hackage.CabalInstall.Install
+-- Copyright : (c) David Himmelstrup 2005
+-- License : BSD-like
+--
+-- Maintainer : lemmih@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- High level interface to package installation.
+-----------------------------------------------------------------------------
+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(..)
+ ,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
diff --git a/Network/Hackage/CabalInstall/Main.hs b/Network/Hackage/CabalInstall/Main.hs
index 7b215861457a75a439650f96b546da05e2b839bb..06720337a6c3bf6f0094056f129946d8199d311b 100644
--- a/Network/Hackage/CabalInstall/Main.hs
+++ b/Network/Hackage/CabalInstall/Main.hs
@@ -17,6 +17,7 @@ import Network.Hackage.CabalInstall.Types (Action (..))
import Network.Hackage.CabalInstall.Setup (parseGlobalArgs, parseInstallArgs)
import Network.Hackage.CabalInstall.Configure (mkConfigFlags)
+import Network.Hackage.CabalInstall.List (list)
import Network.Hackage.CabalInstall.Install (install)
import Network.Hackage.CabalInstall.Info (info)
import Network.Hackage.CabalInstall.Update (update)
@@ -29,21 +30,14 @@ main :: IO ()
main = do args <- getArgs
(action, flags, args) <- parseGlobalArgs args
config <- mkConfigFlags flags
+ let runCmd f = do (globalArgs, pkgs) <- parseInstallArgs args
+ f config globalArgs pkgs
case action of
- InstallCmd
- -> do (globalArgs, pkgs) <- parseInstallArgs args
- install config globalArgs pkgs
- BuildDepCmd
- -> do (globalArgs, pkgs) <- parseInstallArgs args
- buildDep config globalArgs pkgs
- InfoCmd
- -> do (globalArgs, pkgs) <- parseInstallArgs args
- info config globalArgs pkgs
- UpdateCmd
- -> update config
- CleanCmd
- -> clean config
- FetchCmd
- -> fetch config args
- _ -> putStrLn "Unhandled command."
-
+ ListCmd -> runCmd list
+ InstallCmd -> runCmd install
+ BuildDepCmd -> runCmd buildDep
+ InfoCmd -> runCmd info
+ UpdateCmd -> update config
+ CleanCmd -> clean config
+ FetchCmd -> fetch config args
+ _ -> putStrLn "Unhandled command."
diff --git a/Network/Hackage/CabalInstall/Types.hs b/Network/Hackage/CabalInstall/Types.hs
index b1a0b5e083f283cd258fbd29b8fcaab81384be1b..24a4bc55c8fda932c69254bde2d870420ef94368 100644
--- a/Network/Hackage/CabalInstall/Types.hs
+++ b/Network/Hackage/CabalInstall/Types.hs
@@ -26,6 +26,7 @@ data Action
| UpdateCmd
| InfoCmd
| HelpCmd
+ | ListCmd
data TempFlags = TempFlags {
tempHcFlavor :: Maybe CompilerFlavor,
diff --git a/Network/Hackage/Client.hs b/Network/Hackage/Client.hs
index d6d5a46fce1379a1252d6b1b3e86d5bd177da8da..71d2ac516356098c0fd268d14ac6dcb177652de1 100644
--- a/Network/Hackage/Client.hs
+++ b/Network/Hackage/Client.hs
@@ -1,33 +1,70 @@
module Network.Hackage.Client where
-import Network.XmlRpc.Client
-import Network.XmlRpc.Internals
-
import Distribution.Package
+import Distribution.PackageDescription
import Distribution.Version
import Data.Version
import Data.Maybe
+import Text.ParserCombinators.ReadP
+import Distribution.ParseUtils
+
+type PathName = String
-import Network.Hackage.Version
-import Network.Hackage.Interface
+-- Resolved dependency, pkg location and resolved dependencies of the dependency.
+data ResolvedDependency
+ = ResolvedDependency PackageIdentifier String [(Dependency,Maybe ResolvedDependency)]
+ deriving (Eq,Show)
+
+data Pkg = Pkg String [String] String
+ deriving (Show, Read)
getPkgDescription :: String -> PackageIdentifier -> IO (Maybe String)
-getPkgDescription url = remote url "getPkgDescription"
+getPkgDescription url pkgId = do
+ fmap Just ( getFrom url (pathOf pkgId "cabal") )
getPkgDescriptions :: String -> [PackageIdentifier] -> IO [Maybe String]
-getPkgDescriptions url = remote url "getPkgDescriptions"
+getPkgDescriptions url pkgIds = mapM (getPkgDescription url) pkgIds
getDependencies :: String -> [Dependency] -> IO [(Dependency, Maybe ResolvedDependency)]
-getDependencies url = remote url "getDependencies"
+getDependencies _ _ = fail "getDependencies unimplemented" -- remote url "getDependencies"
listPackages :: String -> IO [(PackageIdentifier,[Dependency],String)]
-listPackages url = remote url "listPackages"
+listPackages url = do
+ x <- getFrom url "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)
+ where
+ pkgId = parseWith parsePackageId ident
+ pkgDeps = map (parseWith parseDependency) deps
+ pkgURL = url ++ "/" ++ pathOf pkgId "tar.gz"
+
+pathOf :: PackageIdentifier -> String -> PathName
+pathOf pkgId ext = concat [pkgName pkgId, "/", showPackageId pkgId, ".", ext]
+parseWith :: Show a => ReadP a -> String -> a
+parseWith f s = case reverse (readP_to_S f s) of
+ ((x, _):_) -> x
+ _ -> error s
+
+-- XXX - check for existence?
getPkgLocation :: String -> PackageIdentifier -> IO (Maybe String)
-getPkgLocation url = remote url "getPkgLocation"
+getPkgLocation url pkgId = return . Just $ url ++ "/" ++ pathOf pkgId "tar.gz"
getServerVersion :: String -> IO Version
-getServerVersion url = remote url "getServerVersion"
+getServerVersion url = fail "getServerVersion not implemented" -- remote url "getServerVersion"
+
+
+getFrom :: String -> String -> IO String
+getFrom ('f':'i':'l':'e':':':'/':'/':base) path = do
+ readFile $ base ++ "/" ++ path
+getFrom base path = fail $ "Cannot handle " ++ base ++ "/" ++ path
+
+
+{-
isCompatible :: String -> IO Bool
isCompatible = fmap ((==) clientVersion) . getServerVersion
+-}
diff --git a/dependencies/hackage-client-0.1.0/Network/Hackage/Client.hs b/dependencies/hackage-client-0.1.0/Network/Hackage/Client.hs
index d6d5a46fce1379a1252d6b1b3e86d5bd177da8da..47a954e3d4996175fb37374d0dde360ccfa11f89 100644
--- a/dependencies/hackage-client-0.1.0/Network/Hackage/Client.hs
+++ b/dependencies/hackage-client-0.1.0/Network/Hackage/Client.hs
@@ -11,6 +11,16 @@ import Data.Maybe
import Network.Hackage.Version
import Network.Hackage.Interface
+{-
+data ServerResource
+ = ResourceLocation URL
+ | UpdateLocation ServerResource URL
+ | PackageDescription PackageDescription
+ | AuthorDescription { email ... }
+ | ResourceBundle [ServerResource]
+ deriving (Show, Read, Typeable, Ord, Eq)
+-}
+
getPkgDescription :: String -> PackageIdentifier -> IO (Maybe String)
getPkgDescription url = remote url "getPkgDescription"
@@ -21,7 +31,7 @@ getDependencies :: String -> [Dependency] -> IO [(Dependency, Maybe ResolvedDepe
getDependencies url = remote url "getDependencies"
listPackages :: String -> IO [(PackageIdentifier,[Dependency],String)]
-listPackages url = remote url "listPackages"
+listPackages url = error "moose" -- remote url "listPackages"
getPkgLocation :: String -> PackageIdentifier -> IO (Maybe String)
getPkgLocation url = remote url "getPkgLocation"