cabal-debian-1.3: Distribution/Package/Debian.hs
{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections, TypeSynonymInstances #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-- |
-- Module : Distribution.Package.Debian
-- Copyright : David Fox 2008
--
-- Maintainer : David Fox <dsf@seereason.com>
-- Stability : alpha
-- Portability : portable
--
-- Explanation: Support for generating Debianization from Cabal data.
-- This software may be used and distributed according to the terms of
-- the GNU General Public License, incorporated herein by reference.
module Distribution.Package.Debian
( debian
) where
import Codec.Binary.UTF8.String (decodeString)
import Control.Arrow (second)
import Control.Exception (SomeException, try, bracket, IOException)
import Control.Monad (when,mplus)
import Control.Monad.Reader (ReaderT(runReaderT), ask)
import Control.Monad.Trans (lift)
import Data.Char (isSpace)
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Version (showVersion)
import Debian.Control
import qualified Debian.Relation as D
import Debian.Release (parseReleaseName)
import Debian.Changes (ChangeLogEntry(..), prettyEntry)
import Debian.Time (getCurrentLocalRFC822Time)
import Debian.Version (DebianVersion, prettyDebianVersion)
import Debian.Version.String
import System.Cmd (system)
import System.Directory
import System.FilePath ((</>), dropExtension)
import System.IO (IOMode (ReadMode), hGetContents, hPutStrLn, hSetBinaryMode, openFile, stderr, withFile)
import System.IO.Error (ioeGetFileName, isDoesNotExistError)
import System.Posix.Files (setFileCreationMask)
import System.Unix.Process
import System.Environment
import Distribution.Text (display)
import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..), CompilerId(..))
import Distribution.System (Platform(..), buildOS, buildArch)
import Distribution.License (License(..))
import Distribution.Package (Package(..), PackageIdentifier(..), PackageName(..), Dependency(..))
import Distribution.Simple.Program (defaultProgramConfiguration)
import Distribution.Simple.Configure (configCompiler)
import Distribution.Simple.Utils (die, setupMessage)
import Distribution.PackageDescription (GenericPackageDescription(..), PackageDescription(..), exeName)
import Distribution.PackageDescription.Configuration (finalizePackageDescription)
--import Distribution.ParseUtils (parseQuoted)
import Distribution.Verbosity (Verbosity)
import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..))
import Distribution.Package.Debian.Bundled (Bundled, PackageType(..), debianName, ghcBuiltIns {-, builtIns, ghc6BuiltIns-})
import Distribution.Version (VersionRange(..))
--import qualified Distribution.Compat.ReadP as ReadP
--import Distribution.Text ( Text(parse) )
import Text.PrettyPrint.HughesPJ
import Distribution.Package.Debian.Relations (buildDependencies, docDependencies, allBuildDepends, debianDependencies, cabalDependencies)
{-
_parsePackageId' :: ReadP.ReadP PackageIdentifier PackageIdentifier
_parsePackageId' = parseQuoted parse ReadP.<++ parse
-}
type DebMap = Map.Map String (Maybe DebianVersion)
buildDebVersionMap :: IO DebMap
buildDebVersionMap =
readFile "/var/lib/dpkg/status" >>=
return . either (const []) unControl . parseControl "/var/lib/dpkg/status" >>=
mapM (\ p -> case (lookupP "Package" p, lookupP "Version" p) of
(Just (Field (_, name)), Just (Field (_, version))) ->
return (Just (stripWS name, Just (parseDebianVersion (stripWS version))))
_ -> return Nothing) >>=
return . Map.fromList . catMaybes
(!) :: DebMap -> String -> DebianVersion
m ! k = maybe (error ("No version number for " ++ show k ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m)
trim :: String -> String
trim = dropWhile isSpace
simplePackageDescription :: GenericPackageDescription -> Flags
-> IO (Compiler, PackageDescription)
simplePackageDescription genPkgDesc flags = do
(compiler', _) <- {- fchroot (buildRoot flags) -} (configCompiler (Just (rpmCompiler flags)) Nothing Nothing
defaultProgramConfiguration
(rpmVerbosity flags))
let compiler = case (rpmCompilerVersion flags, rpmCompiler flags) of
(Just v, ghc) -> compiler' {compilerId = CompilerId ghc v}
_ -> compiler'
--installed <- installedPackages
case finalizePackageDescription (rpmConfigurationsFlags flags)
(const True) (Platform buildArch buildOS) (compilerId compiler)
{- (Nothing :: Maybe PackageIndex) -}
[] genPkgDesc of
Left e -> die $ "finalize failed: " ++ show e
Right (pd, _) -> return (compiler, pd)
debian :: GenericPackageDescription -- ^ info from the .cabal file
-> Flags -- ^ command line flags
-> IO ()
debian genPkgDesc flags =
case rpmCompiler flags of
GHC ->
do (compiler, pkgDesc) <- simplePackageDescription genPkgDesc flags
let verbose = rpmVerbosity flags
createDirectoryIfMissing True (debOutputDir flags)
--lbi <- localBuildInfo pkgDesc flags
debVersions <- buildDebVersionMap
cabalPackages <- libPaths compiler debVersions >>= return . Map.fromList . map (\ p -> (cabalName p, p))
bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> do
autoreconf verbose pkgDesc
case debAction flags of
SubstVar name ->
do control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control"
substvars pkgDesc compiler debVersions control cabalPackages name
Debianize ->
debianize True pkgDesc flags compiler (debOutputDir flags)
UpdateDebianization ->
updateDebianization True pkgDesc flags compiler (debOutputDir flags)
c -> die ("the " ++ show c ++ " compiler is not yet supported")
autoreconf :: Verbosity -> PackageDescription -> IO ()
autoreconf verbose pkgDesc = do
ac <- doesFileExist "configure.ac"
when ac $ do
c <- doesFileExist "configure"
when (not c) $ do
setupMessage verbose "Running autoreconf" (packageId pkgDesc)
ret <- system "autoreconf"
case ret of
ExitSuccess -> return ()
ExitFailure n -> die ("autoreconf failed with status " ++ show n)
data PackageInfo = PackageInfo { libDir :: FilePath
, cabalName :: String
, cabalVersion :: String
, devDeb :: Maybe (String, DebianVersion)
, profDeb :: Maybe (String, DebianVersion)
, docDeb :: Maybe (String, DebianVersion) }
-- |Each cabal package corresponds to a directory <name>-<version>,
-- either in /usr/lib or in /usr/lib/haskell-packages/ghc/lib.
-- In that directory is a compiler subdirectory such as ghc-6.8.2.
-- In the ghc subdirectory is one or two library files of the form
-- libHS<name>-<version>.a and libHS<name>-<version>_p.a. We can
-- determine the debian package names by running dpkg -S on these
-- names, or examining the /var/lib/dpkg/info/\*.list files. From
-- these we can determine the source package name, and from that
-- the documentation package name.
substvars :: PackageDescription -- ^info from the .cabal file
-> Compiler -- ^compiler details
-> DebMap
-> Control -- ^The debian/control file
-> Map.Map String PackageInfo -- ^The list of installed cabal packages
-> DebType -- ^The type of deb we want to write substvars for
-> IO ()
substvars pkgDesc _compiler _debVersions control cabalPackages debType =
case (missingBuildDeps, path) of
-- There should already be a .substvars file produced by dh_haskell_prep,
-- keep the relations listed there. They will contain something like this:
-- libghc-cabal-debian-prof.substvars:
-- haskell:Depends=ghc-prof (<< 6.8.2-999), ghc-prof (>= 6.8.2), libghc-cabal-debian-dev (= 0.4)
-- libghc-cabal-debian-dev.substvars:
-- haskell:Depends=ghc (<< 6.8.2-999), ghc (>= 6.8.2)
-- haskell-cabal-debian-doc.substvars:
-- haskell:Depends=ghc-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999)
([], Just path') ->
do old <- try (readFile path') >>= return . either (\ (_ :: SomeException) -> "") id
let new = addDeps old
hPutStrLn stderr (if new /= old
then ("cabal-debian - Updated " ++ show path' ++ ":\n " ++ old ++ "\n ->\n " ++ new)
else ("cabal-debian - No updates found for " ++ show path'))
maybe (return ()) (\ _x -> replaceFile path' new) name
([], Nothing) -> return ()
(missing, _) ->
die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map fst missing) ++
"\nIf this is an obsolete package you may need to withdraw the old versions from the\n" ++
"upstream repository, and uninstall and purge it from your local system.")
where
addDeps old =
case partition (isPrefixOf "haskell:Depends=") (lines old) of
([], other) -> unlines (("haskell:Depends=" ++ showDeps deps) : other)
(hdeps, more) ->
case deps of
[] -> unlines (hdeps ++ more)
_ -> unlines (map (++ (", " ++ showDeps deps)) hdeps ++ more)
path = maybe Nothing (\ x -> Just ("debian/" ++ x ++ ".substvars")) name
name = case debType of Dev -> devDebName; Prof -> profDebName; Doc -> docDebName
deps = case debType of Dev -> devDeps; Prof -> profDeps; Doc -> docDeps
-- We must have build dependencies on the profiling and documentation packages
-- of all the cabal packages.
missingBuildDeps =
let requiredDebs =
concat (map (\ (Dependency (PackageName name) _) ->
case Map.lookup name cabalPackages :: Maybe PackageInfo of
Just info ->
let prof = maybe (devDeb info) Just (profDeb info) in
let doc = docDeb info in
catMaybes [prof, doc]
Nothing -> []) (cabalDependencies pkgDesc)) in
filter (not . (`elem` buildDepNames) . fst) requiredDebs
-- Make a list of the debian devel packages corresponding to cabal packages
-- which are build dependencies
devDeps :: D.Relations
devDeps =
catMaybes (map (\ (Dependency (PackageName name) _) ->
case Map.lookup name cabalPackages :: Maybe PackageInfo of
Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (devDeb package)
Nothing -> Nothing) (cabalDependencies pkgDesc))
profDeps :: D.Relations
profDeps =
maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) devDebName ++
catMaybes (map (\ (Dependency (PackageName name) _) ->
case Map.lookup name cabalPackages :: Maybe PackageInfo of
Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (profDeb package)
Nothing -> Nothing) (cabalDependencies pkgDesc))
docDeps :: D.Relations
docDeps =
catMaybes (map (\ (Dependency (PackageName name) _) ->
case Map.lookup name cabalPackages :: Maybe PackageInfo of
Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (docDeb package)
Nothing -> Nothing) (cabalDependencies pkgDesc))
buildDepNames :: [String]
buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps)
buildDeps :: D.Relations
buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi)
--sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control)))
devDebName = listToMaybe (filter (isSuffixOf "-dev") debNames)
profDebName = listToMaybe (filter (isSuffixOf "-prof") debNames)
docDebName = listToMaybe (filter (isSuffixOf "-doc") debNames)
debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control))))
bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control
bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control
-- |Write a file which we might still be reading from in
-- order to compute the text argument.
replaceFile :: FilePath -> String -> IO ()
replaceFile path text =
try (removeFile back) >>= either chk1 return >> -- This may not exist
try (renameFile path back) >>= either chk2 return >> -- This may not exist
writeFile path text -- This must succeed
where
back = path ++ "~"
chk1 :: IOException -> IO ()
chk1 e =
if ioeGetFileName e == Just back && isDoesNotExistError e
then return ()
else ioError e
chk2 :: IOException -> IO ()
chk2 e =
if ioeGetFileName e == Just path && isDoesNotExistError e
then return ()
else ioError e
libPaths :: Compiler -> DebMap -> IO [PackageInfo]
libPaths compiler debVersions
| compilerFlavor compiler == GHC =
do a <- getDirPaths "/usr/lib"
b <- getDirPaths "/usr/lib/haskell-packages/ghc/lib"
-- Build a map from names of installed debs to version numbers
dpkgFileMap >>= runReaderT (mapM (packageInfo compiler debVersions) (a ++ b)) >>= return . catMaybes
| True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler)
where
getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id
packageInfo :: Compiler -> DebMap -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set String)) IO (Maybe PackageInfo)
packageInfo compiler debVersions (d, f) =
case parseNameVersion f of
Nothing -> return Nothing
Just (p, v) -> lift (doesDirectoryExist (d </> f </> cdir)) >>= cond (return Nothing) (info (d, p, v))
where
cdir = display (compilerId compiler)
info (d, p, v) =
do dev <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ ".a$")
prof <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ "_p.a$")
doc <- debOfFile ("/" ++ p ++ ".haddock$")
return (Just (PackageInfo { libDir = d
, cabalName = p
, cabalVersion = v
, devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev
, profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof
, docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc }))
parseNameVersion s =
case (break (== '-') (reverse s)) of
(_a, "") -> Nothing
(a, b) -> Just (reverse (tail b), reverse a)
-- |Create a map from pathname to the names of the packages that contains that pathname.
-- We need to make sure we consume all the files, so
dpkgFileMap :: IO (Map.Map FilePath (Set.Set String))
dpkgFileMap =
do
let fp = "/var/lib/dpkg/info"
names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list")
let paths = map (fp </>) names
files <- mapM (strictReadF lines) paths
return $ Map.fromList $ zip (map dropExtension names) (map Set.fromList files)
strictReadF :: (String -> r) -> FilePath -> IO r
strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x))
-- strictRead = strictReadF id
-- |Given a path, return the name of the package that owns it.
debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set String)) IO (Maybe String)
debOfFile path =
do mp <- ask
return $ testPath (Map.lookup path mp)
where
testPath :: Maybe (Set.Set FilePath) -> Maybe FilePath
testPath Nothing = Nothing
testPath (Just s) =
case Set.size s of
1 -> Just (Set.findMin s)
_ -> Nothing
cond :: t -> t -> Bool -> t
cond ifF _ifT False = ifF
cond _ifF ifT True = ifT
debianize :: Bool -> PackageDescription -> Flags -> Compiler -> FilePath -> IO ()
debianize force pkgDesc flags compiler tgtPfx =
mapM_ removeIfExists ["debian/control", "debian/changelog"] >>
updateDebianization force pkgDesc flags compiler tgtPfx
removeFileIfExists :: FilePath -> IO ()
removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x))
removeDirectoryIfExists :: FilePath -> IO ()
removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x))
removeIfExists :: FilePath -> IO ()
removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x
updateDebianization :: Bool -- ^whether to forcibly create file
-> PackageDescription -- ^info from the .cabal file
-> Flags -- ^command line flags
-> Compiler -- ^compiler details
-> FilePath -- ^directory in which to create files
-> IO ()
updateDebianization _force pkgDesc flags compiler tgtPfx =
do createDirectoryIfMissing True "debian"
date <- getCurrentLocalRFC822Time
copyright <- try (readFile' (licenseFile pkgDesc)) >>=
return . either (\ (_ :: SomeException) -> showLicense . license $ pkgDesc) id
debianMaintainer <- getDebianMaintainer flags >>= maybe (error "Missing value for --maintainer") return
controlUpdate (tgtPfx </> "control") flags compiler debianMaintainer pkgDesc
changelogUpdate flags (tgtPfx </> "changelog") debianMaintainer pkgDesc date
replaceFile (tgtPfx </> "rules") (cdbsRules pkgDesc)
getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True})
replaceFile (tgtPfx </> "compat") "7" -- should this be hardcoded, or automatically read from /var/lib/dpkg/status?
replaceFile (tgtPfx </> "copyright") copyright
-- The dev postinst and prerm files are generated by haskell-devscripts via cdbs.
return ()
readFile' :: FilePath -> IO String
readFile' path
= do
file <- openFile path ReadMode
hSetBinaryMode file True
hGetContents file
{-
Create a debian maintainer field from the environment variables:
DEBFULLNAME (preferred) or NAME
DEBEMAIL (preferred) or EMAIL
More work could be done to match dch, but this is sufficient for
now. Here is what the man page for dch has to say:
If the environment variable DEBFULLNAME is set, this will be used for
the maintainer full name; if not, then NAME will be checked. If the
environment variable DEBEMAIL is set, this will be used for the email
address. If this variable has the form "name <email>", then the
maintainer name will also be taken from here if neither DEBFULLNAME
nor NAME is set. If this variable is not set, the same test is
performed on the environment variable EMAIL. Next, if the full name
has still not been determined, then use getpwuid(3) to determine the
name from the pass‐word file. If this fails, use the previous
changelog entry. For the email address, if it has not been set from
DEBEMAIL or EMAIL, then look in /etc/mailname, then attempt to build
it from the username and FQDN, otherwise use the email address in the
previous changelog entry. In other words, it’s a good idea to set
DEBEMAIL and DEBFULLNAME when using this script.
-}
getDebianMaintainer :: Flags -> IO (Maybe String)
getDebianMaintainer flags =
case debMaintainer flags of
Nothing -> envMaintainer
maint -> return maint
where
envMaintainer :: IO (Maybe String)
envMaintainer =
do env <- map (second decodeString) `fmap` getEnvironment
return $ do fullname <- lookup "DEBFULLNAME" env `mplus` lookup "NAME" env
email <- lookup "DEBEMAIL" env `mplus` lookup "EMAIL" env
return (fullname ++ " <" ++ email ++ ">")
cdbsRules :: PackageDescription -> String
cdbsRules pkgDesc =
unlines (intercalate [""] ([header, execs, comments] {- ++ devrules ++ profrules -} ))
where
header =
["#!/usr/bin/make -f",
"",
"DEB_CABAL_PACKAGE = " ++ debianName Extra (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc))),
"",
"include /usr/share/cdbs/1/rules/debhelper.mk",
"include /usr/share/cdbs/1/class/hlibrary.mk"]
execs =
case executables pkgDesc of
[] -> []
[e] ->
let exe = exeName e
src = "dist-ghc/build/" ++ exe ++ "/" ++ exe
dst = "debian/" ++ exeDeb e ++ "/usr/bin/" ++ exe in
[ -- Magic rule required to get binaries to build in packages that have no libraries
"build/" ++ exeDeb e ++ ":: build-ghc-stamp"
, "binary-fixup/" ++ exeDeb e ++ "::"
, "\tinstall -m 755 -s -D " ++ src ++ " " ++ dst ++ " || true"]
_ ->
[ -- Magic rule required to get binaries to build in packages that have no libraries
"build/" ++ utilsDeb ++ ":: build-ghc-stamp"
, "binary-fixup/" ++ utilsDeb ++ "::" ] ++
map (\ executable ->
let exe = exeName executable
src = "dist-ghc/build/" ++ exe ++ "/" ++ exe
dst = "debian/" ++ utilsDeb ++ "/usr/bin/" ++ exe in
"\tinstall -m 755 -s -D " ++ src ++ " " ++ dst ++ " || true") (executables pkgDesc)
comments =
["# How to install an extra file into the documentation package",
"#binary-fixup/" ++ docDeb ++ "::",
"#\techo \"Some informative text\" > debian/" ++ docDeb ++ "/usr/share/doc/" ++ docDeb ++ "/AnExtraDocFile"]
_p = pkgName . package $ pkgDesc
_libName = unPackageName _p
docDeb = debianName Documentation (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc)))
utilsDeb = debianName Utilities (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc)))
exeDeb e = debianName Extra (PackageName (exeName e)) AnyVersion
list :: b -> ([a] -> b) -> [a] -> b
list d f l = case l of [] -> d; _ -> f l
controlUpdate :: FilePath -> Flags -> Compiler -> String -> PackageDescription -> IO ()
controlUpdate path flags compiler debianMaintainer pkgDesc =
return (ghcBuiltIns compiler) >>= \bundled ->
try (readFile path) >>=
either (\ (_ :: SomeException) -> writeFile path (show (newCtl bundled))) (\ s -> writeFile (path ++ ".new") $! show (merge (newCtl bundled) (oldCtl s)))
where
newCtl bundled = control flags bundled compiler debianMaintainer pkgDesc
oldCtl s = either (const (Control [])) id (parseControl "debian/control" s)
merge (Control new) (Control old) =
case (new, old) of
(_newSource : _new', []) -> Control new
(newSource : new', oldSource : old') ->
Control (mergeParagraphs newSource oldSource : mergeOther new' old')
-- Merge a list of binary package paragraphs
mergeOther new old =
map mergePackages allNames
where
mergePackages name =
case (findPackage name new, findPackage name old) of
(Just x, Nothing) -> x
(Nothing, Just x) -> x
(Just x, Just y) -> mergeParagraphs x y
findPackage name paras = listToMaybe (filter (hasName name) paras)
where hasName name para = lookupP "Package" para == Just name
allNames = newNames ++ (oldNames \\ newNames)
newNames = catMaybes $ map (lookupP "Package") new
oldNames = catMaybes $ map (lookupP "Package") old
mergeParagraphs :: Paragraph' String -> Paragraph' String -> Paragraph' String
mergeParagraphs new@(Paragraph newFields) old@(Paragraph oldFields) =
Paragraph (map mergeField fieldNames)
where
fieldNames = map fieldName oldFields ++ (map fieldName newFields \\ map fieldName oldFields)
fieldName (Field (name, _)) = name
mergeField :: String -> Field
mergeField name =
case (lookupP name new, lookupP name old) of
(Just (Field (_, x)), Nothing) -> Field (name, x)
(Nothing, Just (Field (_, x))) -> Field (name, x)
(Just (Field (_, x)), Just (Field (_, y))) -> Field (name, mergeValues name x y)
_ -> error $ "Internal error"
mergeValues :: String -> String -> String -> String
mergeValues "Build-Depends" x y =
" " ++ (showDeps' "Build-Depends:" $ mergeDeps (parseDeps x) (parseDeps y))
mergeValues "Depends" x y =
" " ++ (showDeps' "Depends:" $ mergeDeps (parseDeps x) (parseDeps y))
mergeValues _ x _ = x
parseDeps s = either (error . show) id (D.parseRelations s)
mergeDeps :: D.Relations -> D.Relations -> D.Relations
mergeDeps x y =
-- foldr :: (a -> b -> b) -> b -> [a] -> b
nub $ foldr insertDep x y
where
insertDep :: [D.Relation] -> D.Relations -> D.Relations
insertDep ys xss =
case depPackageNames ys of
[name] -> case break (\ xs -> depPackageNames xs == [name]) xss of
(a, b : c) -> a ++ [b, ys] ++ c
(a, []) -> a ++ [ys]
_ -> xss ++ [ys]
depPackageNames xs = nub (map depPackageName xs)
depPackageName (D.Rel x _ _) = x
control :: Flags -> Bundled -> Compiler -> String -> PackageDescription -> Control
control flags bundled compiler debianMaintainer pkgDesc =
Control {unControl =
([sourceSpec] ++
develLibrarySpecs ++
profileLibrarySpecs ++
docLibrarySpecs ++
(case executables pkgDesc of
[] -> []
[e] -> [utilsSpec (debianName Extra (PackageName (exeName e)) AnyVersion)]
_ -> [utilsSpec (debianName Utilities (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc))))]))}
where
--buildDepsIndep = ""
sourceSpec =
Paragraph
([Field ("Source", " " ++ debianName Source (pkgName . package $ pkgDesc) (ThisVersion (pkgVersion (package pkgDesc)))),
Field ("Priority", " " ++ "extra"),
Field ("Section", " " ++ "haskell"),
Field ("Maintainer", " " ++ debianMaintainer),
Field ("Build-Depends", " " ++ showDeps' "Build-Depends:" (debianBuildDeps ++ map rel (buildDeps flags))),
Field ("Build-Depends-Indep", " " ++ showDeps' "Build-Depends-Indep:" debianBuildDepsIndep),
--Field ("Build-Depends-Indep", " " ++ buildDepsIndep),
Field ("Standards-Version", " " ++ "3.9.1"),
Field ("Homepage",
" " ++
if homepage pkgDesc == ""
then "http://hackage.haskell.org/package/" ++
unPackageName (pkgName $ package pkgDesc)
else homepage pkgDesc)])
rel x = [D.Rel x Nothing Nothing]
utilsSpec p =
Paragraph
[Field ("Package", " " ++ p),
Field ("Architecture", " " ++ "any"),
Field ("Section", " " ++ "misc"),
-- No telling what the dependencies of an executable might
-- be. The developer will have to fill them in
Field ("Depends", " " ++ showDeps [[D.Rel "${shlibs:Depends}" Nothing Nothing],
[D.Rel "${haskell:Depends}" Nothing Nothing],
[D.Rel "${misc:Depends}" Nothing Nothing]]),
Field ("Description", " " ++ maybe debianDescription (const executableDescription) (library pkgDesc))]
develLibrarySpecs = if isJust (library pkgDesc) then [librarySpec "any" Development] else []
profileLibrarySpecs = if debLibProf flags && isJust (library pkgDesc) then [librarySpec "any" Profiling] else []
docLibrarySpecs = if isJust (library pkgDesc) then [docSpecsParagraph] else []
docSpecsParagraph =
Paragraph
[Field ("Package", " " ++ debianName Documentation (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc)))),
Field ("Architecture", " " ++ "all"),
Field ("Section", " " ++ "doc"),
Field ("Depends", " " ++ showDeps' "Depends:" [[D.Rel "${haskell:Depends}" Nothing Nothing],
[D.Rel "${misc:Depends}" Nothing Nothing]]),
Field ("Recommends", " " ++ "${haskell:Recommends}"),
Field ("Suggests", " " ++ "${haskell:Suggests}"),
Field ("Description", " " ++ libraryDescription Documentation)]
librarySpec arch typ =
Paragraph
[Field ("Package", " " ++ debianName typ (pkgName (package pkgDesc)) (ThisVersion (pkgVersion (package pkgDesc)))),
Field ("Architecture", " " ++ arch),
Field ("Depends", " " ++ showDeps' "Depends:" (
(if typ == Development
then [[D.Rel "${shlibs:Depends}" Nothing Nothing]]
else []) ++
[[D.Rel "${haskell:Depends}" Nothing Nothing],
[D.Rel "${misc:Depends}" Nothing Nothing]])),
Field ("Recommends", " " ++ "${haskell:Recommends}"),
Field ("Suggests", " " ++ "${haskell:Suggests}"),
Field ("Provides", " " ++ "${haskell:Provides}"),
Field ("Description", " " ++ libraryDescription typ)]
-- The haskell-cdbs package contains the hlibrary.mk file with
-- the rules for building haskell packages.
debianBuildDeps :: D.Relations
debianBuildDeps =
nub $
[[D.Rel "debhelper" (Just (D.GRE (parseDebianVersion "7.0"))) Nothing],
[D.Rel "haskell-devscripts" (Just (D.GRE (parseDebianVersion "0.8"))) Nothing],
[D.Rel "cdbs" Nothing Nothing],
[D.Rel "ghc" Nothing Nothing]] ++
(if debLibProf flags then [[D.Rel "ghc-prof" Nothing Nothing]] else []) ++
(concat . map (debianDependencies flags bundled compiler buildDependencies) . allBuildDepends $ pkgDesc)
debianBuildDepsIndep :: D.Relations
debianBuildDepsIndep =
nub $
[[D.Rel "ghc-doc" Nothing Nothing]] ++
(concat . map (debianDependencies flags bundled compiler docDependencies) . allBuildDepends $ pkgDesc)
debianDescription =
(unwords . words . synopsis $ pkgDesc) ++
case description pkgDesc of
"" -> ""
text ->
let text' = text ++ "\n" ++
list "" ("\n Author: " ++) (author pkgDesc) ++
list "" ("\n Upstream-Maintainer: " ++) (maintainer pkgDesc) ++
list "" ("\n Url: " ++) (pkgUrl pkgDesc) in
"\n " ++ (trim . intercalate "\n " . map addDot . lines $ text')
addDot line = if all (flip elem " \t") line then "." else line
executableDescription = " " ++ "An executable built with the " ++ display (package pkgDesc) ++ " library."
libraryDescription Profiling = debianDescription ++ "\n .\n This package contains the libraries compiled with profiling enabled."
libraryDescription Development = debianDescription ++ "\n .\n This package contains the normal library files."
libraryDescription Documentation = debianDescription ++ "\n .\n This package contains the documentation files."
libraryDescription x = error $ "Unexpected library package name suffix: " ++ show x
showDeps :: [[D.Relation]] -> String
showDeps xss = intercalate ", " (map (intercalate " | " . map (show . D.prettyRelation)) xss)
showDeps' :: [a] -> [[D.Relation]] -> String
showDeps' prefix xss =
intercalate (",\n " ++ prefix') (map (intercalate " | " . map (show . D.prettyRelation)) xss)
where prefix' = map (\ _ -> ' ') prefix
changelogUpdate :: Flags -> FilePath -> String -> PackageDescription -> String -> IO ()
changelogUpdate flags path debianMaintainer pkgDesc date =
try (readFile path) >>= either (\ (_ :: SomeException) -> writeFile path log) (const (writeFile (path ++ ".new") log))
where
log = changelog flags debianMaintainer pkgDesc date
changelog :: Flags -> String -> PackageDescription -> String -> String
changelog flags debianMaintainer pkgDesc date =
render (prettyEntry
(Entry { logPackage = debianName Source (pkgName . package $ pkgDesc) (ThisVersion (pkgVersion (package pkgDesc)))
, logVersion = updateOriginal f $ debianVersionNumber pkgDesc
, logDists = [parseReleaseName "unstable"]
, logUrgency = "low"
, logComments = " * Debianization generated by cabal-debian\n\n"
, logWho = debianMaintainer
, logDate = date }))
where
f s = maybe (g s) id (debVersion flags)
g s = maybe "" (\ n -> show n ++ ":") (epoch flags) ++ s ++ "-1~hackage1"
updateOriginal :: (String -> String) -> DebianVersion -> DebianVersion
--updateOriginal f (DebianVersion str dv) = DebianVersion (f str) dv
updateOriginal f v = parseDebianVersion . f . show . prettyDebianVersion $ v
unPackageName :: PackageName -> String
unPackageName (PackageName s) = s
--debianDevelPackageName' (Dependency (PackageName name) _) = debianDevelPackageName name
-- debianPackageName prefix name suffix = prefix ++ (map toLower name) ++ suffix
debianVersionNumber :: PackageDescription -> DebianVersion
debianVersionNumber pkgDesc = parseDebianVersion . showVersion . pkgVersion . package $ pkgDesc
-- generated with:
-- apt-cache show ghc \
-- | grep ^Provides: \
-- | cut -d\ -f2-
-- | sed 's/, /\n/g' \
-- | grep libghc- \
-- | cut -d- -f2- \
-- | grep dev$ \
-- | sed 's/-dev//;s/$/",/;s/^/"/'
{-
base :: Set String
base
= Data.Set.fromList
["array",
"base",
"bin-package-db",
"bytestring",
"cabal",
"containers",
"directory",
"extensible-exceptions",
"filepath",
"ghc-binary",
"ghc-prim",
"haskell2010",
"haskell98",
"hpc",
"integer-gmp",
"old-locale",
"old-time",
"pretty",
"process",
"random",
"rts",
"template-haskell",
"time",
"unix"]
-}
-- | Convert from license to RPM-friendly description. The strings are
-- taken from TagsCheck.py in the rpmlint distribution.
showLicense :: License -> String
showLicense (GPL _) = "GPL"
showLicense (LGPL _) = "LGPL"
showLicense BSD3 = "BSD"
showLicense BSD4 = "BSD-like"
showLicense PublicDomain = "Public Domain"
showLicense AllRightsReserved = "Proprietary"
showLicense OtherLicense = "Non-distributable"