Config.hs 11.7 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Config
4
5
6
7
8
9
10
11
12
-- 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.
-----------------------------------------------------------------------------
13
module Distribution.Client.Config
14
15
16
    ( SavedConfig(..)
    , savedConfigToConfigFlags
    , configRepos
17
    , configPackageDB
18
    , defaultConfigFile
19
    , defaultCabalDir
20
    , defaultCacheDir
21
    , loadConfig
22
    , showConfig
23
24
25
    ) where

import Prelude hiding (catch)
26
import Data.Char (isAlphaNum)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
27
import Data.Maybe (fromMaybe)
28
import Control.Monad (when)
29
import Data.Monoid (Monoid(..))
bjorn@bringert.net's avatar
bjorn@bringert.net committed
30
import System.Directory (createDirectoryIfMissing, getAppUserDataDirectory)
31
import System.FilePath ((</>), takeDirectory)
32
import Network.URI (parseAbsoluteURI, uriToString)
33
import Text.PrettyPrint.HughesPJ (text)
34

35
36
import Distribution.Compat.ReadP as ReadP
         ( ReadP, char, munch1, pfail )
37
import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor)
38
39
import Distribution.ParseUtils
         ( FieldDescr(..), simpleField, listField, liftField, field
40
         , parseFilePathQ, parseTokenQ, showPWarning, ParseResult(..) )
41
import Distribution.Simple.Compiler (PackageDB(..))
42
43
import Distribution.Simple.InstallDirs
         ( InstallDirs(..), PathTemplate, toPathTemplate, fromPathTemplate )
44
import Distribution.Simple.Command (ShowOrParseArgs(..), viewAsFieldDescr)
45
46
47
import Distribution.Simple.Setup
         ( Flag(..), toFlag, fromFlag, fromFlagOrDefault
         , ConfigFlags, configureOptions )
48
import qualified Distribution.Simple.Setup as ConfigFlags
49
50
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Verbosity (Verbosity, normal)
51
52
import Distribution.System
         ( OS(Windows), buildOS )
53

54
import Distribution.Client.Types
55
         ( RemoteRepo(..), Repo(..), Username(..), Password(..) )
56
57
import Distribution.Client.ParseUtils
import Distribution.Client.Utils (readFileIfExists)
58
import Distribution.Simple.Utils (notice, warn)
59

60
61
62
63
64
65
66
67
configPackageDB :: Cabal.ConfigFlags -> PackageDB
configPackageDB config =
  fromFlagOrDefault defaultDB (Cabal.configPackageDB config)
  where
    defaultDB = case Cabal.configUserInstall config of
      NoFlag     -> UserPackageDB
      Flag True  -> UserPackageDB
      Flag False -> GlobalPackageDB
68
69

--
70
-- * Configuration saved in the config file
71
72
--

73
74
75
76
data SavedConfig = SavedConfig {
    configCacheDir          :: Flag FilePath,
    configRemoteRepos       :: [RemoteRepo],     -- ^Available Hackage servers.
    configUploadUsername    :: Flag Username,
77
78
79
    configUploadPassword    :: Flag Password,
    configUserInstallDirs   :: InstallDirs (Flag PathTemplate),
    configGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
80
81
    configFlags             :: ConfigFlags,
    configSymlinkBinDir     :: Flag FilePath
82
83
  }

84
85
86
configUserInstall     :: SavedConfig -> Flag Bool
configUserInstall     =  ConfigFlags.configUserInstall . configFlags

87
88
89
90
91
92
93
configRepos :: SavedConfig -> [Repo]
configRepos config =
  [ let cacheDir = fromFlag (configCacheDir config)
               </> remoteRepoName remote
     in Repo remote cacheDir
  | remote <- configRemoteRepos config ]

94
savedConfigToConfigFlags :: Flag Bool -> SavedConfig -> Cabal.ConfigFlags
95
savedConfigToConfigFlags userInstallFlag config = (configFlags config) {
96
    Cabal.configUserInstall = toFlag userInstall,
97
98
    Cabal.configInstallDirs = if userInstall
                                then configUserInstallDirs config
99
                                else configGlobalInstallDirs config
100
101
  }
  where userInstall :: Bool
102
103
        userInstall = fromFlag $ configUserInstall config
                       `mappend` userInstallFlag
104
105
106
107
108

--
-- * Default config
--

109
110
defaultCabalDir :: IO FilePath
defaultCabalDir = getAppUserDataDirectory "cabal"
111
112

defaultConfigFile :: IO FilePath
113
defaultConfigFile = do dir <- defaultCabalDir
114
115
116
                       return $ dir </> "config"

defaultCacheDir :: IO FilePath
117
118
defaultCacheDir = do dir <- defaultCabalDir
                     return $ dir </> "packages"
119
120
121
122

defaultCompiler :: CompilerFlavor
defaultCompiler = fromMaybe GHC defaultCompilerFlavor

123
124
125
126
127
128
129
defaultUserInstall :: Bool
defaultUserInstall = case buildOS of
  -- We do global installs by default on Windows
  Windows -> False
  -- and per-user installs by default everywhere else
  _       -> True

130
defaultUserInstallDirs :: IO (InstallDirs (Flag PathTemplate))
Duncan Coutts's avatar
Duncan Coutts committed
131
132
133
defaultUserInstallDirs =
    do userPrefix <- defaultCabalDir
       return $ defaultGlobalInstallDirs {
134
         prefix = toFlag (toPathTemplate userPrefix)
Duncan Coutts's avatar
Duncan Coutts committed
135
       }
136

137
138
defaultGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
defaultGlobalInstallDirs = mempty
139

140
141
defaultSavedConfig :: IO SavedConfig
defaultSavedConfig =
Duncan Coutts's avatar
Duncan Coutts committed
142
    do userInstallDirs <- defaultUserInstallDirs
143
       cacheDir        <- defaultCacheDir
144
145
146
147
148
149
       return SavedConfig {
           configFlags = mempty {
               ConfigFlags.configHcFlavor    = toFlag defaultCompiler
             , ConfigFlags.configVerbosity   = toFlag normal
             , ConfigFlags.configUserInstall = toFlag defaultUserInstall
             , ConfigFlags.configInstallDirs = error
Duncan Coutts's avatar
Duncan Coutts committed
150
151
               "ConfigFlags.installDirs: avoid this field."
               --use UserInstallDirs or GlobalInstallDirs instead
152
             }
153
154
155
156
157
158
         , configUserInstallDirs   = userInstallDirs
         , configGlobalInstallDirs = defaultGlobalInstallDirs
         , configCacheDir          = toFlag cacheDir
         , configRemoteRepos       = [defaultRemoteRepo]
         , configUploadUsername    = mempty
         , configUploadPassword    = mempty
159
         , configSymlinkBinDir     = mempty
160
161
162
         }

defaultRemoteRepo :: RemoteRepo
163
164
165
defaultRemoteRepo = RemoteRepo "hackage.haskell.org" uri
  where
    Just uri = parseAbsoluteURI "http://hackage.haskell.org/packages/archive"
166
167
168
169
170

--
-- * Config file reading
--

171
172
173
loadConfig :: Verbosity -> FilePath -> IO SavedConfig
loadConfig verbosity configFile = 
    do defaultConf <- defaultSavedConfig
174
       minp <- readFileIfExists configFile
175
       case minp of
176
177
         Nothing -> do notice verbosity $ "Config file " ++ configFile ++ " not found."
                       notice verbosity $ "Writing default configuration to " ++ configFile
178
                       writeDefaultConfigFile configFile defaultConf
179
                       return defaultConf
180
         Just inp -> case parseBasicStanza configFieldDescrs defaultConf' inp of
181
                       ParseOk ws conf -> 
182
183
                           do when (not $ null ws) $ warn verbosity $
                                unlines (map (showPWarning configFile) ws)
184
                              return conf
185
                       ParseFailed err -> 
186
                           do warn verbosity $ "Error parsing config file " 
187
                                            ++ configFile ++ ": " ++ showPError err
188
                              warn verbosity $ "Using default configuration."
189
                              return defaultConf
190
           where defaultConf' = defaultConf { configRemoteRepos = [] }
191

192
writeDefaultConfigFile :: FilePath -> SavedConfig -> IO ()
193
writeDefaultConfigFile file cfg = 
194
    do createDirectoryIfMissing True (takeDirectory file)
195
       writeFile file $ showFields configWriteFieldDescrs cfg ++ "\n"
bjorn@bringert.net's avatar
bjorn@bringert.net committed
196

197
showConfig :: SavedConfig -> String
198
199
showConfig = showFields configFieldDescrs

200
-- | All config file fields.
201
configFieldDescrs :: [FieldDescr SavedConfig]
202
203
204
configFieldDescrs =
    map ( configFlagsField . viewAsFieldDescr) (configureOptions ShowArgs)
    ++ configCabalInstallFieldDescrs
205
206
    ++ map userInstallDirField installDirDescrs
    ++ map globalInstallDirField installDirDescrs
207

208
209
210
configCabalInstallFieldDescrs :: [FieldDescr SavedConfig]
configCabalInstallFieldDescrs =
    [ listField "repos"
211
                (text . showRepo)                  parseRepo
212
                configRemoteRepos (\rs cfg -> cfg { configRemoteRepos = rs })
213
    , simpleField "cachedir"
214
215
                (text . show . fromFlagOrDefault "")
                (fmap emptyToNothing parseFilePathQ)
216
                configCacheDir    (\d cfg -> cfg { configCacheDir = d })
217
    , simpleField "hackage-username"
218
219
                (text . show . fromFlagOrDefault "" . fmap unUsername)
                (fmap (fmap Username . emptyToNothing) parseTokenQ)
220
221
                configUploadUsername    (\d cfg -> cfg { configUploadUsername = d })
    , simpleField "hackage-password"
222
223
                (text . show . fromFlagOrDefault "" . fmap unPassword)
                (fmap (fmap Password . emptyToNothing) parseTokenQ)
224
                configUploadPassword    (\d cfg -> cfg { configUploadPassword = d })
225
226
227
228
    , simpleField "symlink-bindir"
                (text . show . fromFlagOrDefault "")
                (fmap emptyToNothing parseFilePathQ)
                configSymlinkBinDir     (\d cfg -> cfg { configSymlinkBinDir = d })
229
230
231
    ]
    where emptyToNothing "" = mempty
          emptyToNothing f  = toFlag f
232
233
234
235
236
237
                              
-- | The subset of the config file fields that we write out
-- if the config file is missing.
configWriteFieldDescrs :: [FieldDescr SavedConfig]
configWriteFieldDescrs = configCabalInstallFieldDescrs
                         ++ [f | f <- configFieldDescrs, fieldName f `elem` ["compiler", "user-install"]]
238

239
installDirDescrs :: [FieldDescr (InstallDirs (Flag PathTemplate))]
240
installDirDescrs =
Duncan Coutts's avatar
Duncan Coutts committed
241
242
243
244
245
246
247
    [ installDirField "prefix"     prefix     (\d ds -> ds { prefix     = d })
    , installDirField "bindir"     bindir     (\d ds -> ds { bindir     = d })
    , installDirField "libdir"     libdir     (\d ds -> ds { libdir     = d })
    , installDirField "libexecdir" libexecdir (\d ds -> ds { libexecdir = d })
    , installDirField "datadir"    datadir    (\d ds -> ds { datadir    = d })
    , installDirField "docdir"     docdir     (\d ds -> ds { docdir     = d })
    , installDirField "htmldir"    htmldir    (\d ds -> ds { htmldir    = d })
248
249
    ]

250
251
252
configFlagsField :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
configFlagsField = liftField configFlags (\ff cfg -> cfg{configFlags=ff})

253

254
userInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig
255
256
257
258
259
userInstallDirField f = modifyFieldName ("user-"++) $
    liftField configUserInstallDirs 
              (\d cfg -> cfg { configUserInstallDirs = d }) 
              f

260
globalInstallDirField :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig
261
262
263
264
265
globalInstallDirField f = modifyFieldName ("global-"++) $
    liftField configGlobalInstallDirs 
              (\d cfg -> cfg { configGlobalInstallDirs = d }) 
              f

266
installDirField :: String 
267
268
269
                -> (InstallDirs (Flag PathTemplate) -> Flag PathTemplate) 
                -> (Flag PathTemplate -> InstallDirs (Flag PathTemplate) -> InstallDirs (Flag PathTemplate))
                -> FieldDescr (InstallDirs (Flag PathTemplate))
270
installDirField name get set = 
271
272
273
    liftField get set $
      field name (text . fromPathTemplate . fromFlag)
                 (fmap (toFlag . toPathTemplate) parseFilePathQ)
274
275
276

modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
modifyFieldName f d = d { fieldName = f (fieldName d) }
277

278
showRepo :: RemoteRepo -> String
279
280
showRepo repo = remoteRepoName repo ++ ":"
             ++ uriToString id (remoteRepoURI repo) []
281

282
parseRepo :: ReadP r RemoteRepo
283
284
parseRepo = do name <- munch1 (\c -> isAlphaNum c || c `elem` "_-.")
               char ':'
285
286
287
288
289
290
               uriStr <- munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?")
               uri <- maybe ReadP.pfail return (parseAbsoluteURI uriStr)
               return $ RemoteRepo {
                 remoteRepoName = name,
                 remoteRepoURI  = uri
               }
291