Commit ef899c7b authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Make logging and verboisty a bit more consistent

Use the Distribution.Simple.Utils functions and eliminate use of printf
parent 94b5d602
......@@ -15,7 +15,6 @@ module Hackage.Config
, packageFile
, packageDir
, listInstalledPackages
, message
, pkgURL
, defaultConfigFile
, loadConfig
......@@ -24,14 +23,13 @@ module Hackage.Config
) where
import Prelude hiding (catch)
import Control.Monad (when)
import Data.Char (isAlphaNum, toLower)
import Data.List (intersperse)
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty)
import Control.Monad (when)
import Data.Monoid (Monoid(mempty))
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)
......@@ -46,10 +44,11 @@ import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, toPathTem
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
import Distribution.Simple.Setup (toFlag, fromFlagOrDefault)
import Distribution.Version (showVersion)
import Distribution.Verbosity (Verbosity, normal)
import Distribution.Verbosity (normal)
import Hackage.Types (ConfigFlags (..), PkgInfo (..), Repo(..))
import Hackage.Utils
import Distribution.Simple.Utils (notice, warn)
-- | Full path to the local cache directory for a repository.
......@@ -80,9 +79,6 @@ listInstalledPackages cfg comp conf =
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),
......@@ -155,20 +151,22 @@ defaultConfigFlags =
loadConfig :: FilePath -> IO ConfigFlags
loadConfig configFile =
do defaultConf <- defaultConfigFlags
let verbosity = configVerbose defaultConf
minp <- readFileIfExists configFile
case minp of
Nothing -> do hPutStrLn stderr $ "Config file " ++ configFile ++ " not found."
hPutStrLn stderr $ "Writing default configuration to " ++ configFile
Nothing -> do notice verbosity $ "Config file " ++ configFile ++ " not found."
notice verbosity $ "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
do when (not $ null ws) $
warn verbosity $ "Config file: " ++ unlines ws
return conf
ParseFailed err ->
do hPutStrLn stderr $ "Error parsing config file "
do warn verbosity $ "Error parsing config file "
++ configFile ++ ": " ++ showPError err
hPutStrLn stderr $ "Using default configuration."
warn verbosity $ "Using default configuration."
return defaultConf
writeDefaultConfigFile :: FilePath -> ConfigFlags -> IO ()
......
......@@ -27,18 +27,17 @@ import Network.HTTP (ConnError(..), Request (..), simpleHTTP
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.Config (repoCacheDir, packageFile, packageDir, pkgURL)
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 Distribution.Simple.Utils (die, notice, debug)
import System.FilePath ((</>), (<.>))
import System.Directory (copyFile)
import System.IO (IOMode(..), hPutStr, Handle, hClose, openBinaryFile)
......@@ -50,10 +49,10 @@ readURI uri
| otherwise = do
eitherResult <- simpleHTTP (Request uri GET [] "")
case eitherResult of
Left err -> fail $ printf "Failed to download '%s': %s" (show uri) (show err)
Left err -> die $ "Failed to download '" ++ 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)
| otherwise -> die $ "Failed to download '" ++ show uri ++ "': Invalid HTTP code: " ++ show (rspCode rsp)
downloadURI :: FilePath -- ^ Where to put it
-> URI -- ^ What to download
......@@ -89,12 +88,13 @@ downloadPackage cfg pkg
= do let url = pkgURL pkg
dir = packageDir cfg pkg
path = packageFile cfg pkg
message cfg verbose $ "GET " ++ show url
debug verbosity $ "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)
Just err -> die $ "Failed to download '" ++ showPackageId (pkgInfoId pkg) ++ "': " ++ show err
Nothing -> return path
where verbosity = configVerbose cfg
-- Downloads an index file to [config-dir/packages/serv-id].
downloadIndex :: ConfigFlags -> Repo -> IO FilePath
......@@ -105,7 +105,7 @@ downloadIndex cfg repo
createDirectoryIfMissing True dir
mbError <- downloadFile path url
case mbError of
Just err -> fail $ printf "Failed to download index '%s'" (show err)
Just err -> die $ "Failed to download index '" ++ show err ++ "'"
Nothing -> return path
-- |Returns @True@ if the package has already been fetched.
......@@ -117,17 +117,18 @@ 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))
then do notice verbosity $ "'" ++ showPackageId (pkgInfoId pkg) ++ "' is cached."
return (packageFile cfg pkg)
else do printf "Downloading '%s'...\n" (showPackageId (pkgInfoId pkg))
else do notice verbosity $ "Downloading '" ++ showPackageId (pkgInfoId pkg) ++ "'..."
downloadPackage cfg pkg
where verbosity = configVerbose cfg
-- |Fetch a list of packages and their dependencies.
fetch :: ConfigFlags -> Compiler -> ProgramConfiguration -> [UnresolvedDependency] -> IO ()
fetch cfg comp conf deps
= do depTree <- resolveDependencies cfg comp conf deps
case packagesToInstall depTree of
Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Right pkgs -> do ps <- filterM (fmap not . isFetched cfg) $ map fst pkgs
mapM_ (fetchPackage cfg) ps
......
......@@ -28,6 +28,7 @@ import System.IO.Error (isDoesNotExistError)
import Distribution.PackageDescription (parsePackageDescription, ParseResult(..))
import Distribution.Package (PackageIdentifier(..))
import Distribution.Version (readVersion)
import Distribution.Simple.Utils (warn)
getKnownPackages :: ConfigFlags -> IO [PkgInfo]
getKnownPackages cfg
......@@ -39,9 +40,10 @@ readRepoIndex cfg repo =
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)
warn verbosity "The package list does not exist. Run 'cabal update' to download it."
_ -> warn verbosity (show e)
return [])
where verbosity = configVerbose cfg
parseRepoIndex :: Repo -> ByteString -> [PkgInfo]
parseRepoIndex repo s =
......
......@@ -22,22 +22,24 @@ import Distribution.Package (showPackageId)
import Distribution.ParseUtils (showDependency)
import Distribution.Simple.Compiler (Compiler)
import Distribution.Simple.Program (ProgramConfiguration)
import Distribution.Simple.Utils as Utils (notice, info)
import Data.List (intersperse, nubBy)
import Text.Printf (printf)
import Data.List (nubBy)
info :: ConfigFlags -> Compiler -> ProgramConfiguration -> [UnresolvedDependency] -> IO ()
info cfg comp conf deps
= do apkgs <- resolveDependencies cfg comp conf deps
mapM_ (infoPkg cfg) $ flattenResolvedPackages apkgs
details <- mapM (infoPkg cfg) (flattenResolvedPackages apkgs)
Utils.info verbosity $ unlines (map (" "++) (concat details))
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]
Left missing -> notice verbosity $
"The requested packages cannot be installed, because of missing dependencies:\n"
++ showDependencies missing
Right pkgs -> notice verbosity $
"These packages would be installed:\n"
++ unlines [showPackageId (pkgInfoId pkg) | (pkg,_) <- pkgs]
where verbosity = configVerbose cfg
flattenResolvedPackages :: [ResolvedPackage] -> [ResolvedPackage]
flattenResolvedPackages = nubBy fulfillSame. concatMap flatten
......@@ -45,21 +47,23 @@ flattenResolvedPackages = nubBy fulfillSame. concatMap flatten
flatten p = [p]
fulfillSame a b = fulfills a == fulfills b
infoPkg :: ConfigFlags -> ResolvedPackage -> IO ()
infoPkg :: ConfigFlags -> ResolvedPackage -> IO [String]
infoPkg _ (Installed dep p)
= do printf " Requested: %s\n" (show $ showDependency dep)
printf " Installed: %s\n\n" (showPackageId p)
= return ["Requested: " ++ show (showDependency dep)
," Installed: " ++ showPackageId p]
infoPkg cfg (Available dep pkg flags 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 [ if set then flag else '-':flag
| (flag, set) <- flags ])
printf " Location: %s\n" (pkgURL pkg)
printf " Local: %s\n\n" pkgFile
return ["Requested: " ++ show (showDependency dep)
," Using: " ++ showPackageId (pkgInfoId pkg)
," Depends: " ++ showDependencies (map fulfills deps)
," Options: " ++ unwords [ if set then flag else '-':flag
| (flag, set) <- flags ]
," Location: " ++ pkgURL pkg
," Local: " ++ if fetched
then packageFile cfg pkg
else "*Not downloaded"
]
infoPkg _ (Unavailable dep)
= do printf " Requested: %s\n" (show $ showDependency dep)
printf " Not available!\n\n"
= return ["Requested: " ++ show (showDependency dep)
," Not available!"
]
......@@ -21,10 +21,6 @@ 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)
......@@ -41,9 +37,7 @@ import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils (defaultPackageDesc)
import Distribution.Package (showPackageId, PackageIdentifier(..))
import Distribution.PackageDescription (readPackageDescription)
import Distribution.Verbosity
import Distribution.Simple.Utils as Utils (notice, info, debug, die)
-- |Installs the packages needed to satisfy a list of dependencies.
......@@ -60,7 +54,7 @@ installLocalPackage cfg comp conf configFlags =
resolvedDeps <- resolveDependenciesLocal cfg comp conf desc
(Cabal.configConfigurationsFlags configFlags)
case packagesToInstall resolvedDeps of
Left missing -> fail $ "Unresolved dependencies: " ++ showDependencies missing
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Right pkgs -> installPackages cfg configFlags pkgs
installUnpackedPkg cfg configFlags Nothing
......@@ -68,9 +62,10 @@ installRepoPackages :: ConfigFlags -> Compiler -> ProgramConfiguration -> Cabal.
installRepoPackages cfg comp conf configFlags 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."
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Right [] -> notice verbosity "All requested packages already installed. Nothing to do."
Right pkgs -> installPackages cfg configFlags pkgs
where verbosity = configVerbose cfg
installPackages :: ConfigFlags
-> Cabal.ConfigFlags -- ^Options which will be passed to every package.
......@@ -107,19 +102,20 @@ installPkg cfg configFlags (pkg,flags)
= do pkgPath <- fetchPackage cfg pkg
tmp <- getTemporaryDirectory
let p = pkgInfoId pkg
tmpDirPath = tmp </> printf "TMP%sTMP" (showPackageId p)
tmpDirPath = tmp </> ("TMP" ++ showPackageId p)
path = tmpDirPath </> showPackageId p
bracket_ (createDirectoryIfMissing True tmpDirPath)
(removeDirectoryRecursive tmpDirPath)
(do message cfg verbose (printf "Extracting %s to %s..." pkgPath tmpDirPath)
(do info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ 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
when (not e) $ die $ "Package .cabal file not found: " ++ show descFilePath
let configFlags' = configFlags {
Cabal.configConfigurationsFlags =
Cabal.configConfigurationsFlags configFlags ++ flags }
installUnpackedPkg cfg configFlags' (Just path))
where verbosity = configVerbose cfg
installUnpackedPkg :: ConfigFlags
-> Cabal.ConfigFlags -- ^ Arguments for this package
......@@ -132,7 +128,7 @@ installUnpackedPkg cfg configFlags mpath
where
configureOptions = mkPkgOps cfg configFlags
setup cmds
= do message cfg verbose $
= do debug (configVerbose cfg) $
"setupWrapper in " ++ show mpath ++ " :\n " ++ show cmds
setupWrapper cmds mpath
......
......@@ -18,9 +18,10 @@ import Hackage.Types
import Hackage.Fetch
import Hackage.Tar
import Distribution.Simple.Utils (notice)
import qualified Data.ByteString.Lazy as BS
import System.FilePath (dropExtension)
import Text.Printf
-- | 'update' downloads the package list from all known servers
update :: ConfigFlags -> IO ()
......@@ -30,6 +31,7 @@ updateRepo :: ConfigFlags
-> Repo
-> IO ()
updateRepo cfg repo =
do printf "Downloading package list from server '%s'\n" (repoURL repo)
do notice verbosity $ "Downloading package list from server '" ++ repoURL repo ++ "'"
indexPath <- downloadIndex cfg repo
BS.readFile indexPath >>= BS.writeFile (dropExtension indexPath) . gunzip
where verbosity = configVerbose cfg
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