Config.hs 11.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
-----------------------------------------------------------------------------
-- |
-- 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
    ( packagesDirectory
15
    , repoCacheDir
16
17
    , packageFile
    , packageDir
18
    , getKnownPackages
bjorn@bringert.net's avatar
bjorn@bringert.net committed
19
    , message
20
21
22
23
24
    , pkgURL
    , defaultConfigFile
    , loadConfig
    , programConfiguration
    , findCompiler
25
26
27
    ) where

import Prelude hiding (catch)
28
import Control.Exception (catch, Exception(IOException),evaluate)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
29
import Control.Monad (when)
30
import Control.Monad.Error (mplus, filterM) -- Using Control.Monad.Error to get the Error instance for IO.
31
32
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
33
import Data.Char (isAlphaNum, toLower)
34
import Data.List (intersperse)
35
import Data.Maybe (mapMaybe, fromMaybe)
36
import System.Directory (Permissions (..), getPermissions, createDirectoryIfMissing
37
                            ,getTemporaryDirectory)
38
39
import System.IO.Error (isDoesNotExistError)
import System.IO (hPutStrLn, stderr)
40
import System.IO.Unsafe
41
import Text.PrettyPrint.HughesPJ (text)
42

43
44
import Distribution.Compat.ReadP (ReadP, char, munch1, readS_to_P)
import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)
45
46
47
import Distribution.Package (PackageIdentifier(..), showPackageId)
import Distribution.PackageDescription (GenericPackageDescription(..)
                                       , PackageDescription(..)
48
                                       , parsePackageDescription, ParseResult(..))
49
import Distribution.ParseUtils (FieldDescr, simpleField, listField, liftField, field)
50
51
import Distribution.Simple.Compiler (Compiler)
import qualified Distribution.Simple.Configure as Configure (configCompiler)
52
import Distribution.Simple.InstallDirs (InstallDirTemplates(..), PathTemplate, defaultInstallDirs)
53
import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)
54
import Distribution.Version (Dependency, showVersion)
mnislaih's avatar
mnislaih committed
55
import Distribution.Verbosity
56
import System.FilePath ((</>), takeExtension, (<.>))
57
import System.Directory
58

59
import Network.Hackage.CabalInstall.Tar (readTarArchive, tarFileName)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
60
import Network.Hackage.CabalInstall.Types (ConfigFlags (..), PkgInfo (..), Repo(..))
61
62
63
import Network.Hackage.CabalInstall.Utils


64
65
66
67
68
69
-- |Name of the packages directory.
packagesDirectoryName :: FilePath
packagesDirectoryName = "packages"

-- | Full path to the packages directory.
packagesDirectory :: ConfigFlags -> FilePath
70
packagesDirectory cfg = configCacheDir cfg </> packagesDirectoryName
71

72
73
74
-- | Full path to the local cache directory for a repository.
repoCacheDir :: ConfigFlags -> Repo -> FilePath
repoCacheDir cfg repo = packagesDirectory cfg </> repoName repo
75

76
77
78
79
80
81
82
83
84
85
86
87
88
89
-- |Generate the full path to the locally cached copy of
-- the tarball for a given @PackageIdentifer@.
packageFile :: ConfigFlags -> PackageIdentifier -> Repo -> FilePath
packageFile cfg pkg repo = packageDir cfg pkg repo
                           </> showPackageId 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 -> PackageIdentifier -> Repo -> FilePath
packageDir cfg pkg repo = repoCacheDir cfg repo
                      </> pkgName pkg
                      </> showVersion (pkgVersion pkg)

90
91
getKnownPackages :: ConfigFlags -> IO [PkgInfo]
getKnownPackages cfg
92
    = fmap concat $ mapM (readRepoIndex cfg) $ configRepos cfg
93
94
95
96

readRepoIndex :: ConfigFlags -> Repo -> IO [PkgInfo]
readRepoIndex cfg repo =
    do let indexFile = repoCacheDir cfg repo </> "00-index.tar"
97
       fmap (parseRepoIndex repo) (BS.readFile indexFile)
98
          `catch` (\e
99
                 -> do hPutStrLn stderr ("Warning: Problem opening package list '"
100
                                          ++ indexFile ++ "'.")
101
102
103
104
105
                       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 [])
106

107
108
parseRepoIndex :: Repo -> ByteString -> [PkgInfo]
parseRepoIndex repo s =
109
110
    do (hdr, content) <- readTarArchive s
       if takeExtension (tarFileName hdr) == ".cabal"
111
         then case parsePackageDescription (BS.unpack content) of
112
113
114
115
                    ParseOk _ descr -> return $ PkgInfo { 
                                                         pkgRepo = repo,
                                                         pkgDesc = descr
                                                        }
116
                    _               -> error $ "Couldn't read cabal file " ++ show (tarFileName hdr)
117
118
         else fail "Not a .cabal file"

bjorn@bringert.net's avatar
bjorn@bringert.net committed
119
120
message :: ConfigFlags -> Verbosity -> String -> IO ()
message cfg v s = when (configVerbose cfg >= v) (putStrLn s)
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183

-- | Generate the URL of the tarball for a given package.
pkgURL :: PackageIdentifier -> Repo -> String
pkgURL pkg repo = joinWith "/" [repoURL repo, pkgName pkg, showVersion (pkgVersion pkg), showPackageId pkg] 
                           ++ ".tar.gz"
                      where joinWith tok = concat . intersperse tok

--
-- * Compiler and programs
--

-- FIXME: should look at config
programConfiguration :: ConfigFlags -> IO ProgramConfiguration
programConfiguration cfg = return defaultProgramConfiguration 

findCompiler :: ConfigFlags -> IO (Compiler, ProgramConfiguration)
findCompiler cfg = 
    do conf <- programConfiguration cfg
       Configure.configCompiler 
                    (Just (configCompiler cfg)) 
                    Nothing Nothing conf (configVerbose cfg)


--
-- * Default config
--

defaultConfigDir :: IO FilePath
defaultConfigDir = getAppUserDataDirectory "cabal"

defaultConfigFile :: IO FilePath
defaultConfigFile = do dir <- defaultConfigDir
                       return $ dir </> "config"

defaultCacheDir :: IO FilePath
defaultCacheDir = defaultConfigDir

defaultCompiler :: CompilerFlavor
defaultCompiler = fromMaybe GHC defaultCompilerFlavor

defaultConfigFlags :: IO ConfigFlags
defaultConfigFlags = 
    do installDirs <- defaultInstallDirs defaultCompiler True
       cacheDir    <- defaultCacheDir
       return $ ConfigFlags 
               { configCompiler    = defaultCompiler
               , configInstallDirs = installDirs
               , 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."
184
185
                       hPutStrLn stderr $ "Writing default configuration to " ++ configFile ++ "."
                       writeDefaultConfigFile configFile defaultConf
186
187
188
189
190
191
192
193
194
195
196
197
                       return defaultConf
         Just inp -> case parseBasicStanza configFieldDescrs defaultConf inp of
                       ParseOk ws dummyConf -> 
                           do mapM_ (hPutStrLn stderr . ("Config file warning: " ++)) ws
                              -- There is a data dependency within the config file.
                              -- The default installation paths depend on the compiler.
                              -- Hence we need to do two passes through the config file.
                              installDirs <- defaultInstallDirs (configCompiler dummyConf) True
                              let conf = defaultConf { configInstallDirs = installDirs }
                              case parseBasicStanza configFieldDescrs conf inp of
                                ParseOk _ conf' -> return conf'
                       ParseFailed err -> 
198
199
200
201
                           do hPutStrLn stderr $ "Error parsing config file " 
                                            ++ configFile ++ ": " ++ showPError err
                              hPutStrLn stderr $ "Using default configuration."
                              return defaultConf
202

bjorn@bringert.net's avatar
bjorn@bringert.net committed
203
-- FIXME: finish this
204
205
206
writeDefaultConfigFile :: FilePath -> ConfigFlags -> IO ()
writeDefaultConfigFile file cfg = 
    writeFile file $ showFields configWriteFieldDescrs cfg
bjorn@bringert.net's avatar
bjorn@bringert.net committed
207

208
-- | All config file fields.
209
210
configFieldDescrs :: [FieldDescr ConfigFlags]
configFieldDescrs =
211
212
213
214
215
216
    [ 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 })
217
218
    ] ++ configWriteFieldDescrs

219

220
221
222
223
-- | The subset of the config file fields that we write out
-- if the config file is missing.
configWriteFieldDescrs :: [FieldDescr ConfigFlags]
configWriteFieldDescrs =
224
225
226
227
228
229
    [  simpleField "compiler"
                (text . show)   parseCompilerFlavor
                configCompiler (\c cfg -> cfg { configCompiler = c })
    , listField "repos"
                (text . showRepo)                  parseRepo
                configRepos    (\rs cfg -> cfg { configRepos = rs })
230
231
232
    , simpleField "cachedir"
                (text . show)                  (readS_to_P reads)
                configCacheDir    (\d cfg -> cfg { configCacheDir = d })
233
    , boolField "user-install" configUserInstall (\u cfg -> cfg { configUserInstall = u })
234
    , installDirField "prefix" prefixDirTemplate (\d ds -> ds { prefixDirTemplate = d })
235
    ] 
236

237
238
239
240
241
242
243
244
installDirField :: String 
                -> (InstallDirTemplates -> PathTemplate) 
                -> (PathTemplate -> InstallDirTemplates -> InstallDirTemplates)
                -> FieldDescr ConfigFlags
installDirField name get set = 
    liftField (get . configInstallDirs) 
               (\d cfg -> cfg { configInstallDirs = set d (configInstallDirs cfg) }) $
               field name (text . show) (readS_to_P reads)
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

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 (const True)
               return $ Repo { repoName = name, repoURL = url }