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

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

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

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

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

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

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

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

150
        let instConf | genPkgConf = genPkgConfigFile
151
                     | inplace    = inplacePkgConfigFile distPref
152
                     | otherwise  = installedPkgConfigFile distPref
153

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

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

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

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

David Himmelstrup's avatar
David Himmelstrup committed
173
      LHC -> do
174 175 176 177
        config_flags <- case packageDB of
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
David Himmelstrup's avatar
David Himmelstrup committed
178 179 180 181 182 183 184

        let instConf | genPkgConf = genPkgConfigFile
                     | inplace    = inplacePkgConfigFile distPref
                     | otherwise  = installedPkgConfigFile distPref

        when (genPkgConf || not genScript) $ do
          info verbosity ("create " ++ instConf)
185
          writeInstalledConfig distPref pkg_descr lbi inplace instConf
David Himmelstrup's avatar
David Himmelstrup committed
186 187 188 189

        let register_flags   = let conf = if genScript && not isWindows
                                             then ["-"]
                                             else [instConf]
190
                                in "update" : conf
David Himmelstrup's avatar
David Himmelstrup committed
191 192

        let allFlags = config_flags ++ register_flags
193
        let Just pkgTool = lookupProgram lhcPkgProgram (withPrograms lbi)
David Himmelstrup's avatar
David Himmelstrup committed
194 195 196 197 198 199 200

        case () of
          _ | genPkgConf -> return ()
            | genScript ->
              do cfg <- showInstalledConfig distPref pkg_descr lbi inplace
                 rawSystemPipe pkgTool regScriptLocation cfg allFlags
          _ -> rawSystemProgram verbosity pkgTool allFlags
201 202 203

      Hugs -> do
        when inplace $ die "--inplace is not supported with Hugs"
204
        let installDirs = absoluteInstallDirs (packageId pkg_descr) lbi NoCopyDest
205 206 207
        createDirectoryIfMissingVerbose verbosity True (libdir installDirs)
        installOrdinaryFile verbosity (installedPkgConfigFile distPref)
                                      (libdir installDirs </> "package.conf")
208 209 210
      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
211

212 213 214 215 216
-- -----------------------------------------------------------------------------
-- The installed package config

-- |Register doesn't drop the register info file, it must be done in a
-- separate step.
217
writeInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo
218 219
                     -> Bool -> FilePath -> IO ()
writeInstalledConfig distPref pkg_descr lbi inplace instConf = do
220
  pkg_config <- showInstalledConfig distPref pkg_descr lbi inplace
221
  writeFileAtomic instConf (pkg_config ++ "\n")
222

223
-- |Create a string suitable for writing out to the package config file
224
showInstalledConfig :: FilePath -> PackageDescription -> LocalBuildInfo -> Bool
225
  -> IO String
226 227
showInstalledConfig distPref pkg_descr lbi inplace
    = do cfg <- mkInstalledPackageInfo distPref pkg_descr lbi inplace
228
         return (showInstalledPackageInfo cfg)
229

230 231 232 233
removeInstalledConfig :: FilePath -> IO ()
removeInstalledConfig distPref = do
  try $ removeFile $ installedPkgConfigFile distPref
  try $ removeFile $ inplacePkgConfigFile distPref
234 235 236 237 238 239 240
  return ()

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

242 243
installedPkgConfigFile :: FilePath -> FilePath
installedPkgConfigFile distPref = distPref </> "installed-pkg-config"
simonmar's avatar
simonmar committed
244

245 246
inplacePkgConfigFile :: FilePath -> FilePath
inplacePkgConfigFile distPref = distPref </> "inplace-pkg-config"
247

248 249 250 251
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo

mkInstalledPackageInfo
252
        :: FilePath
253
        -> PackageDescription
254 255 256 257
        -> LocalBuildInfo
        -> Bool
        -> IO InstalledPackageInfo
mkInstalledPackageInfo distPref pkg_descr lbi inplace = do
258
  --TODO: get rid of getCurrentDirectory here, make this function pure
259
  pwd <- getCurrentDirectory
260 261
  let
        lib = fromJust (library pkg_descr) -- checked for Nothing earlier
262 263
        clbi = fromJust (libraryConfig lbi)
        --TODO: ^^ pass explicitly rather than using fromJust
264
        bi = libBuildInfo lib
265
        build_dir = pwd </> buildDir lbi
266 267
        installDirs = absoluteInstallDirs (packageId pkg_descr) lbi NoCopyDest
        inplaceDirs = (absoluteInstallDirs (packageId pkg_descr) lbi NoCopyDest) {
268 269 270 271 272 273
                        datadir    = pwd,
                        datasubdir = distPref,
                        docdir     = inplaceDocdir,
                        htmldir    = inplaceHtmldir,
                        haddockdir = inplaceHtmldir
                      }
274 275 276
          where inplaceDocdir  = pwd </> distPref </> "doc"
                inplaceHtmldir = inplaceDocdir </> "html"
                                               </> display (packageName pkg_descr)
277 278 279 280
        (absinc,relinc) = partition isAbsolute (includeDirs bi)
        installIncludeDir | null (installIncludes bi) = []
                          | otherwise = [includedir installDirs]
        haddockInterfaceDir
281 282 283 284 285
         | inplace   = haddockdir inplaceDirs
         | otherwise = haddockdir installDirs
        haddockHtmlDir
         | inplace   = htmldir inplaceDirs
         | otherwise = htmldir installDirs
286 287 288
        libraryDir
         | inplace   = build_dir
         | otherwise = libdir installDirs
289 290 291
        hasModules = not $ null (exposedModules lib)
                        && null (otherModules bi)
        hasLibrary = hasModules || not (null (cSources bi))
292
    in
293
    return InstalledPackageInfo {
294
        IPI.package           = packageId pkg_descr,
295 296 297
        IPI.license           = license pkg_descr,
        IPI.copyright         = copyright pkg_descr,
        IPI.maintainer        = maintainer pkg_descr,
298
        IPI.author            = author pkg_descr,
299
        IPI.stability         = stability pkg_descr,
300 301 302 303
        IPI.homepage          = homepage pkg_descr,
        IPI.pkgUrl            = pkgUrl pkg_descr,
        IPI.description       = description pkg_descr,
        IPI.category          = category pkg_descr,
304
        IPI.exposed           = libExposed lib,
305 306
        IPI.exposedModules    = exposedModules lib,
        IPI.hiddenModules     = otherModules bi,
307 308 309 310 311 312
        IPI.importDirs        = [ libraryDir | hasModules ],
        IPI.libraryDirs       = if hasLibrary
                                  then libraryDir : extraLibDirs bi
                                  else              extraLibDirs bi,
        IPI.hsLibraries       = ["HS" ++ display (packageId pkg_descr)
                                | hasLibrary ],
313
        IPI.extraLibraries    = extraLibs bi,
314
        IPI.extraGHCiLibraries= [],
315 316
        IPI.includeDirs       = absinc ++ if inplace
                                            then map (pwd </>) relinc
317
                                            else installIncludeDir,
318
        IPI.includes          = includes bi,
319
        IPI.depends           = componentPackageDeps clbi,
ijones's avatar
ijones committed
320
        IPI.hugsOptions       = concat [opts | (Hugs,opts) <- options bi],
321 322 323 324
        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
325
        IPI.ldOptions         = ldOptions bi,
326
        IPI.frameworkDirs     = [],
ijones's avatar
ijones committed
327
        IPI.frameworks        = frameworks bi,
328 329
        IPI.haddockInterfaces = [haddockInterfaceDir </> haddockName pkg_descr],
        IPI.haddockHTMLs      = [haddockHtmlDir]
330
        }
331

simonmar's avatar
simonmar committed
332 333
-- -----------------------------------------------------------------------------
-- Unregistration
334

ijones's avatar
ijones committed
335
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
336
unregister pkg_descr lbi regFlags = do
337
  let genScript = fromFlag (regGenScript regFlags)
338
      verbosity = fromFlag (regVerbosity regFlags)
339 340
      packageDB = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
                                    (regPackageDB regFlags)
341
      installDirs = absoluteInstallDirs (packageId pkg_descr) lbi NoCopyDest
342
  setupMessage verbosity "Unregistering" (packageId pkg_descr)
343
  case compilerFlavor (compiler lbi) of
344
    GHC -> do
345
        config_flags <- case packageDB of
346 347
          GlobalPackageDB      -> return []
          UserPackageDB        -> return ["--user"]
348
          SpecificPackageDB db -> return ["--package-conf=" ++ db]
349

350
        let removeCmd = ["unregister", display (packageId pkg_descr)]
351 352
        let Just pkgTool = lookupProgram ghcPkgProgram (withPrograms lbi)
            allArgs      = removeCmd ++ config_flags
353
        if genScript
354 355
          then rawSystemEmit pkgTool unregScriptLocation allArgs
          else rawSystemProgram verbosity pkgTool allArgs
ijones's avatar
ijones committed
356
    Hugs -> do
357
        try $ removeDirectoryRecursive (libdir installDirs)
358
        return ()
359
    NHC -> do
360
        try $ removeDirectoryRecursive (libdir installDirs)
361
        return ()
ijones's avatar
ijones committed
362
    _ ->
363
        die ("only unregistering with GHC and Hugs is implemented")
ijones's avatar
ijones committed
364

365 366 367 368
-- |Like rawSystemProgram, but emits to a script instead of exiting.
-- FIX: chmod +x?
rawSystemEmit :: ConfiguredProgram  -- ^Program to run
              -> FilePath  -- ^Script name
369
              -> [String]  -- ^Args
370
              -> IO ()
371
rawSystemEmit prog scriptName extraArgs
372 373
 = case buildOS of
       Windows ->
374 375
           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
376 377 378 379
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
380 381
  where args = programArgs prog ++ extraArgs
        path = programPath prog
382

383
-- |Like rawSystemEmit, except it has string for pipeFrom. FIX: chmod +x
384 385
rawSystemPipe :: ConfiguredProgram
              -> FilePath  -- ^Script location
386 387
              -> String    -- ^where to pipe from
              -> [String]  -- ^Args
388
              -> IO ()
389
rawSystemPipe prog scriptName pipeFrom extraArgs
390 391
 = case buildOS of
       Windows ->
392 393
           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
394 395 396 397 398 399
                                  ++ "echo '" ++ escapeForShell pipeFrom
                                  ++ "' | "
                                  ++ (path ++ concatMap (' ':) args)
                                  ++ "\n")
               p <- getPermissions scriptName
               setPermissions scriptName p{executable=True}
400
  where escapeForShell [] = []
401 402
        escapeForShell ('\'':cs) = "'\\''" ++ escapeForShell cs
        escapeForShell (c   :cs) = c        : escapeForShell cs
403 404
        args = programArgs prog ++ extraArgs
        path = programPath prog