-----------------------------------------------------------------------------
-- |
-- 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 }