Register.hs 16.6 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
ijones's avatar
ijones committed
3
-- Module      :  Distribution.Simple.Register
4
-- Copyright   :  Isaac Jones 2003-2004
5
--
Duncan Coutts's avatar
Duncan Coutts committed
6
-- Maintainer  :  cabal-devel@haskell.org
ijones's avatar
ijones committed
7
-- Portability :  portable
8
--
Duncan Coutts's avatar
Duncan Coutts committed
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
-- This module deals with registering and unregistering packages. There are a
-- couple ways it can do this, one is to do it directly. Another is to generate
-- a script that can be run later to do it. The idea here being that the user
-- is shielded from the details of what command to use for package registration
-- for a particular compiler. In practice this aspect was not especially
-- popular so we also provide a way to simply generate the package registration
-- file which then must be manually passed to @ghc-pkg@. It is possible to
-- generate registration information for where the package is to be installed,
-- or alternatively to register the package inplace in the build tree. The
-- latter is occasionally handy, and will become more important when we try to
-- build multi-package systems.
--
-- This module does not delegate anything to the per-compiler modules but just
-- mixes it all in in this module, which is rather unsatisfactory. The script
-- generation and the unregister feature are not well used or tested.
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

{- Copyright (c) 2003-2004, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

56
module Distribution.Simple.Register (
57
58
        register,
        unregister,
59
        writeInstalledConfig,
60
        removeInstalledConfig,
61
        removeRegScripts,
62
  ) where
63

64
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
65
                                           InstallDirs(..),
66
                                           absoluteInstallDirs)
67
import Distribution.Simple.BuildPaths (haddockName)
68
69
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
70
71
72
import Distribution.Simple.Program (ConfiguredProgram, programPath,
                                    programArgs, rawSystemProgram,
                                    lookupProgram, ghcPkgProgram)
73
74
75
import Distribution.Simple.Setup
         ( RegisterFlags(..), CopyDest(..)
         , fromFlag, fromFlagOrDefault, flagToMaybe )
76
77
import Distribution.PackageDescription (PackageDescription(..),
                                              BuildInfo(..), Library(..))
78
import Distribution.Package
79
         ( Package(..), packageName )
80
import Distribution.InstalledPackageInfo
81
82
         ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo)
         , showInstalledPackageInfo )
83
import qualified Distribution.InstalledPackageInfo as IPI
84
import Distribution.Simple.Utils
85
         ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic
Duncan Coutts's avatar
Duncan Coutts committed
86
         , die, info, notice, setupMessage )
87
import Distribution.System
88
         ( OS(..), buildOS )
89
90
import Distribution.Text
         ( display )
91

92
import System.FilePath ((</>), (<.>), isAbsolute)
93
94
95
import System.Directory (removeFile, getCurrentDirectory,
                         removeDirectoryRecursive,
                         setPermissions, getPermissions,
96
                         Permissions(executable))
97
import System.IO.Error (try)
ijones's avatar
ijones committed
98

99
import Control.Monad (when)
100
import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)
101
import Data.List (partition)
simonmar's avatar
simonmar committed
102

103
regScriptLocation :: FilePath
104
105
106
regScriptLocation = case buildOS of
                        Windows -> "register.bat"
                        _       -> "register.sh"
107
108

unregScriptLocation :: FilePath
109
110
111
unregScriptLocation = case buildOS of
                          Windows -> "unregister.bat"
                          _       -> "unregister.sh"
112

simonmar's avatar
simonmar committed
113
114
115
-- -----------------------------------------------------------------------------
-- Registration

ijones's avatar
ijones committed
116
register :: PackageDescription -> LocalBuildInfo
ijones's avatar
ijones committed
117
         -> RegisterFlags -- ^Install in the user's database?; verbose
ijones's avatar
ijones committed
118
         -> IO ()
119
register pkg_descr lbi regFlags
ijones's avatar
ijones committed
120
  | isNothing (library pkg_descr) = do
121
    setupMessage (fromFlag $ regVerbosity regFlags) "No package to register" (packageId pkg_descr)
ijones's avatar
ijones committed
122
123
    return ()
  | otherwise = do
124
125
    let distPref = fromFlag $ regDistPref regFlags
        isWindows = case buildOS of Windows -> True; _ -> False
126
        genScript = fromFlag (regGenScript regFlags)
127
        genPkgConf = isJust (flagToMaybe (regGenPkgConf regFlags))
128
        genPkgConfigDefault = display (packageId pkg_descr) <.> "conf"
129
        genPkgConfigFile = fromMaybe genPkgConfigDefault
130
                                     (fromFlag (regGenPkgConf regFlags))
131
        verbosity = fromFlag (regVerbosity regFlags)
132
        packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
133
        inplace  = fromFlag (regInPlace regFlags)
134
135
136
137
138
        message | genPkgConf = "Writing package registration file: "
                            ++ genPkgConfigFile ++ " for"
                | genScript = "Writing registration script: "
                           ++ regScriptLocation ++ " for"
                | otherwise = "Registering"
139
    setupMessage verbosity message (packageId pkg_descr)
140

141
    case compilerFlavor (compiler lbi) of
142
143
      GHC -> do
        config_flags <- case packageDB of
144
145
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
146
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
147

148
        let instConf | genPkgConf = genPkgConfigFile
149
                     | inplace    = inplacePkgConfigFile distPref
150
                     | otherwise  = installedPkgConfigFile distPref
151

152
        when (genPkgConf || not genScript) $ do
153
          info verbosity ("create " ++ instConf)
154
          writeInstalledConfig distPref pkg_descr lbi inplace (Just instConf)
155

156
        let register_flags   = let conf = if genScript && not isWindows
157
158
                                             then ["-"]
                                             else [instConf]
159
160
                                in "update" : conf

Duncan Coutts's avatar
Duncan Coutts committed
161
        let allFlags = config_flags ++ register_flags
162
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
163

164
165
166
        case () of
          _ | genPkgConf -> return ()
            | genScript ->
167
              do cfg <- showInstalledConfig distPref pkg_descr lbi inplace
168
169
                 rawSystemPipe pkgTool regScriptLocation cfg allFlags
          _ -> rawSystemProgram verbosity pkgTool allFlags
170

ijones's avatar
ijones committed
171
      Hugs -> do
172
        when inplace $ die "--inplace is not supported with Hugs"
173
        let installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
174
175
176
        createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
        copyFileVerbose verbosity (installedPkgConfigFile distPref)
            (libdir installDirs </> "package.conf")
177
178
179
      JHC -> notice verbosity "registering for JHC (nothing to do)"
      NHC -> notice verbosity "registering nhc98 (nothing to do)"
      _   -> die "only registering with GHC/Hugs/jhc/nhc98 is implemented"
simonmar's avatar
simonmar committed
180

181
182
183
184
185
-- -----------------------------------------------------------------------------
-- The installed package config

-- |Register doesn't drop the register info file, it must be done in a
-- separate step.
186
187
188
189
190
191
writeInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo
                     -> Bool -> Maybe FilePath -> IO ()
writeInstalledConfig distPref pkg_descr lbi inplace instConfOverride = do
  pkg_config <- showInstalledConfig distPref pkg_descr lbi inplace
  let instConfDefault | inplace   = inplacePkgConfigFile distPref
                      | otherwise = installedPkgConfigFile distPref
192
      instConf = fromMaybe instConfDefault instConfOverride
193
  writeFileAtomic instConf (pkg_config ++ "\n")
194

195
-- |Create a string suitable for writing out to the package config file
196
showInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo -> Bool
197
  -> IO String
198
199
showInstalledConfig distPref pkg_descr lbi inplace
    = do cfg <- mkInstalledPackageInfo distPref pkg_descr lbi inplace
200
         return (showInstalledPackageInfo cfg)
201

202
203
204
205
removeInstalledConfig :: FilePath -> IO ()
removeInstalledConfig distPref = do
  try $ removeFile $ installedPkgConfigFile distPref
  try $ removeFile $ inplacePkgConfigFile distPref
206
207
208
209
210
211
212
  return ()

removeRegScripts :: IO ()
removeRegScripts = do
  try $ removeFile regScriptLocation
  try $ removeFile unregScriptLocation
  return ()
213

214
215
installedPkgConfigFile :: FilePath -> FilePath
installedPkgConfigFile distPref = distPref </> "installed-pkg-config"
simonmar's avatar
simonmar committed
216

217
218
inplacePkgConfigFile :: FilePath -> FilePath
inplacePkgConfigFile distPref = distPref </> "inplace-pkg-config"
219

220
221
222
223
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

mkInstalledPackageInfo
224
        :: FilePath
225
        -> PackageDescription
226
227
228
229
        -> LocalBuildInfo
        -> Bool
        -> IO InstalledPackageInfo
mkInstalledPackageInfo distPref pkg_descr lbi inplace = do
230
  pwd <- getCurrentDirectory
231
232
  let
        lib = fromJust (library pkg_descr) -- checked for Nothing earlier
233
        bi = libBuildInfo lib
234
        build_dir = pwd </> buildDir lbi
235
        installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
236
        inplaceDirs = (absoluteInstallDirs pkg_descr lbi NoCopyDest) {
237
238
239
240
241
242
                        datadir    = pwd,
                        datasubdir = distPref,
                        docdir     = inplaceDocdir,
                        htmldir    = inplaceHtmldir,
                        haddockdir = inplaceHtmldir
                      }
243
244
245
          where inplaceDocdir  = pwd </> distPref </> "doc"
                inplaceHtmldir = inplaceDocdir </> "html"
                                               </> display (packageName pkg_descr)
246
247
248
249
        (absinc,relinc) = partition isAbsolute (includeDirs bi)
        installIncludeDir | null (installIncludes bi) = []
                          | otherwise = [includedir installDirs]
        haddockInterfaceDir
250
251
252
253
254
         | inplace   = haddockdir inplaceDirs
         | otherwise = haddockdir installDirs
        haddockHtmlDir
         | inplace   = htmldir inplaceDirs
         | otherwise = htmldir installDirs
255
256
257
        libraryDir
         | inplace   = build_dir
         | otherwise = libdir installDirs
258
259
260
        hasModules = not $ null (exposedModules lib)
                        && null (otherModules bi)
        hasLibrary = hasModules || not (null (cSources bi))
261
    in
262
    return InstalledPackageInfo {
263
        IPI.package           = packageId pkg_descr,
264
265
266
        IPI.license           = license pkg_descr,
        IPI.copyright         = copyright pkg_descr,
        IPI.maintainer        = maintainer pkg_descr,
267
        IPI.author            = author pkg_descr,
268
        IPI.stability         = stability pkg_descr,
269
270
271
272
        IPI.homepage          = homepage pkg_descr,
        IPI.pkgUrl            = pkgUrl pkg_descr,
        IPI.description       = description pkg_descr,
        IPI.category          = category pkg_descr,
273
        IPI.exposed           = libExposed lib,
274
275
        IPI.exposedModules    = exposedModules lib,
        IPI.hiddenModules     = otherModules bi,
276
277
278
279
280
281
        IPI.importDirs        = [ libraryDir | hasModules ],
        IPI.libraryDirs       = if hasLibrary
                                  then libraryDir : extraLibDirs bi
                                  else              extraLibDirs bi,
        IPI.hsLibraries       = ["HS" ++ display (packageId pkg_descr)
                                | hasLibrary ],
282
        IPI.extraLibraries    = extraLibs bi,
283
        IPI.extraGHCiLibraries= [],
284
285
        IPI.includeDirs       = absinc ++ if inplace
                                            then map (pwd </>) relinc
286
                                            else installIncludeDir,
287
        IPI.includes          = includes bi,
288
        IPI.depends           = packageDeps lbi,
ijones's avatar
ijones committed
289
        IPI.hugsOptions       = concat [opts | (Hugs,opts) <- options bi],
290
291
292
293
        IPI.ccOptions         = [], -- NB. NOT ccOptions bi!
                                    -- We don't want cc-options to be
                                    -- propagated to C ompilations in other
                                    -- packages.
ijones's avatar
ijones committed
294
        IPI.ldOptions         = ldOptions bi,
295
        IPI.frameworkDirs     = [],
ijones's avatar
ijones committed
296
        IPI.frameworks        = frameworks bi,
297
298
        IPI.haddockInterfaces = [haddockInterfaceDir </> haddockName pkg_descr],
        IPI.haddockHTMLs      = [haddockHtmlDir]
299
        }
300

simonmar's avatar
simonmar committed
301
302
-- -----------------------------------------------------------------------------
-- Unregistration
303

ijones's avatar
ijones committed
304
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
305
unregister pkg_descr lbi regFlags = do
306
  let genScript = fromFlag (regGenScript regFlags)
307
      verbosity = fromFlag (regVerbosity regFlags)
308
      packageDB = fromFlagOrDefault (withPackageDB lbi) (regPackageDB regFlags)
309
      installDirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
310
  setupMessage verbosity "Unregistering" (packageId pkg_descr)
311
  case compilerFlavor (compiler lbi) of
312
    GHC -> do
313
        config_flags <- case packageDB of
314
315
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
316
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
317

318
        let removeCmd = ["unregister", display (packageId pkg_descr)]
319
320
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
            allArgs      = removeCmd ++ config_flags
321
        if genScript
322
323
          then rawSystemEmit pkgTool unregScriptLocation allArgs
          else rawSystemProgram verbosity pkgTool allArgs
ijones's avatar
ijones committed
324
    Hugs -> do
325
        try $ removeDirectoryRecursive (libdir installDirs)
326
        return ()
327
    NHC -> do
328
        try $ removeDirectoryRecursive (libdir installDirs)
329
        return ()
ijones's avatar
ijones committed
330
    _ ->
331
        die ("only unregistering with GHC and Hugs is implemented")
ijones's avatar
ijones committed
332

333
334
335
336
-- |Like rawSystemProgram, but emits to a script instead of exiting.
-- FIX: chmod +x?
rawSystemEmit :: ConfiguredProgram  -- ^Program to run
              -> FilePath  -- ^Script name
337
              -> [String]  -- ^Args
338
              -> IO ()
339
rawSystemEmit prog scriptName extraArgs
340
341
 = case buildOS of
       Windows ->
342
343
           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
344
345
346
347
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
348
349
  where args = programArgs prog ++ extraArgs
        path = programPath prog
350

351
-- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
352
353
rawSystemPipe :: ConfiguredProgram
              -> FilePath  -- ^Script location
354
355
              -> String    -- ^where to pipe from
              -> [String]  -- ^Args
356
              -> IO ()
357
rawSystemPipe prog scriptName pipeFrom extraArgs
358
359
 = case buildOS of
       Windows ->
360
361
           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
362
363
364
365
366
367
                                  ++ "echo '" ++ escapeForShell pipeFrom
                                  ++ "' | "
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
368
  where escapeForShell [] = []
369
370
        escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
        escapeForShell (c   :cs) = c        : escapeForShell cs
371
372
        args = programArgs prog ++ extraArgs
        path = programPath prog