{-# LANGUAGE CPP, TypeSynonymInstances #-} -- | -- Module : Distribution.Package.Debian -- Copyright : David Fox 2008 -- -- Maintainer : David Fox -- 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 Control.Exception (try, bracket) import Control.Monad (when,mplus) import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toLower, isSpace) import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Version (showVersion) import Debian.Control import qualified Debian.Relation as D import Debian.Release (parseReleaseName) import Debian.Changes (ChangeLogEntry(..)) import Debian.Time (getCurrentLocalRFC822Time) import Debian.Version import Debian.Version.String import System.Cmd (system) import System.Directory import System.FilePath (()) import System.IO (hPutStrLn, stderr) import System.Posix.Files (setFileCreationMask) import System.Unix.Process import System.Environment --import Text.ParserCombinators.ReadP import Distribution.Text (display) import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) --import Distribution.Simple.Configure (localBuildInfoFile) import Distribution.System (buildOS, buildArch) import Distribution.License (License(..)) import Distribution.Package (Package(..), PackageIdentifier(..), PackageName(..), Dependency(..)) import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Configure (configCompiler, maybeGetPersistBuildConfig) import Distribution.Simple.InstallDirs (InstallDirs(..), InstallDirTemplates, toPathTemplate) import Distribution.Simple.Register (writeInstalledConfig) --import Distribution.Simple.Setup (defaultRegisterFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.PackageIndex (PackageIndex,fromList) import Distribution.Simple.Utils (die, setupMessage) import Distribution.PackageDescription (GenericPackageDescription(..), PackageDescription(..), allBuildInfo, buildTools, pkgconfigDepends, exeName) import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.ParseUtils (parseQuoted) import Distribution.Verbosity (Verbosity) import Distribution.Version (VersionRange(..)) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..)) import Distribution.Package.Debian.Bundled import qualified Distribution.Compat.ReadP as ReadP import Distribution.Text ( Text(parse) ) 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 m ! k = maybe (error ("No version number for " ++ show k ++ " in " ++ show m)) id (Map.findWithDefault Nothing k m) {- trim s = case matchRegex re s of Just [x, _, _] -> x _ -> error $ "Internal error: trim " ++ show s where re = mkRegex ("^[ \t\n]*(" ++ trimmed ++ ")[ \t\n]*") trimmed = "([^ \t\n](.*[^ \t\n])?)?" -} trim = dropWhile isSpace -- installedPackages :: Package pkg => IO [PackageIndex pkg] installedPackages = do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked case code of [ExitSuccess] -> return . fromList $ map (last . map fst . ReadP.readP_to_S parsePackageId') (words out) result -> error $ "Failure: " ++ cmd ++ " -> " ++ show result ++ " (" ++ err ++ ")" where cmd = "ghc-pkg list --simple-output" simplePackageDescription :: GenericPackageDescription -> Flags -> IO (Compiler, PackageDescription) simplePackageDescription genPkgDesc flags = do (compiler, _) <- configCompiler (Just (rpmCompiler flags)) Nothing Nothing defaultProgramConfiguration (rpmVerbosity flags) installed <- installedPackages case finalizePackageDescription (rpmConfigurationsFlags flags) (Nothing :: Maybe (PackageIndex PackageIdentifier)) buildOS buildArch (compilerId compiler) [] 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) localBuildInfo :: PackageDescription -> Flags -> IO LocalBuildInfo localBuildInfo pkgDesc flags = maybeGetPersistBuildConfig defaultDistPref >>= maybe setup return >>= writeInstalledConfig' where -- Warning - passing the --ghc flag explicitly here probably -- disables support for other compilers. setup = system ("runhaskell Setup configure --ghc --prefix " ++ rpmPrefix flags) >> maybeGetPersistBuildConfig defaultDistPref >>= return . maybe (error ("Failed to create " ++ defaultDistPref)) id writeInstalledConfig' lbi = if isNothing (library pkgDesc) then error "cabal-debian - Unsupported: package without a library section" else writeInstalledConfig defaultDistPref pkgDesc lbi False Nothing >> return lbi 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 -, -- either in /usr/lib or in /usr/lib/haskell-packages/ghc6/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-.a and libHS-_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: -- libghc6-cabal-debian-prof.substvars: -- haskell:Depends=ghc6-prof (<< 6.8.2-999), ghc6-prof (>= 6.8.2), libghc6-cabal-debian-dev (= 0.4) -- libghc6-cabal-debian-dev.substvars: -- haskell:Depends=ghc6 (<< 6.8.2-999), ghc6 (>= 6.8.2) -- haskell-cabal-debian-doc.substvars: -- haskell:Depends=ghc6-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999) ([], Just path') -> do old <- try (readFile path') >>= return . either (const "") 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 -> []) cabalDeps) 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) cabalDeps) 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) cabalDeps) 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) cabalDeps) cabalDeps :: [Dependency] cabalDeps = allBuildDepends 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) >> -- This may not exist try (renameFile path back) >> -- This may not exist try (writeFile path text) >>= -- This must succeed either (\ e -> error ("writeFile " ++ show path ++ ": " ++ show e)) return where back = path ++ "~" libPaths :: Compiler -> DebMap -> IO [PackageInfo] libPaths compiler debVersions | compilerFlavor compiler == GHC = do a <- getDirPaths "/usr/lib" b <- getDirPaths "/usr/lib/haskell-packages/ghc6/lib" -- Build a map from names of installed debs to version numbers 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 (const []) id packageInfo :: Compiler -> DebMap -> (FilePath, String) -> IO (Maybe PackageInfo) packageInfo compiler debVersions (d, f) = case parseNameVersion f of Nothing -> return Nothing Just (p, v) -> 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) -- |Given a path, return the name of the package that owns it. debOfFile :: FilePath -> IO (Maybe String) debOfFile s = do (out, _err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked case code of [ExitSuccess] -> return (takePackageName out) _ -> return Nothing where cmd = "cd /var/lib/dpkg/info && grep '" ++ s ++ "' *.list" -- We already know here that suff actually is a suffix of s --dropSuffix suff s = take (length s - length suff) s takePackageName :: String -> Maybe String takePackageName s = f "" s where f name ('.':'l':'i':'s':'t':':':_) = Just (reverse name) f name (x : xs) = f (x : name) xs f _ [] = Nothing -- Determine the documentation package name. Look for .haddock {- devToDoc :: Compiler -> String -> IO (Maybe String) devToDoc compiler name | compilerFlavor compiler == GHC = case maybe Nothing (dropSuffix "-dev") (dropPrefix "libghc6-" name) of Just base -> do let name1 = "libghc6-" ++ base ++ "-doc" let name2 = "libghc6-" ++ base ++ "-doc" exists1 <- doesFileExist ("/var/lib/dpkg/info/" ++ name1 ++ ".list") case exists1 of True -> return (Just name1) False -> do exists2 <- doesFileExist ("/var/lib/dpkg/info/" ++ name2 ++ ".list") case exists2 of True -> return (Just name2) False -> return Nothing where dropSuffix :: String -> String -> Maybe String dropSuffix suff s = case isSuffixOf suff s of True -> Just (take (length s - length suff) s) False -> Nothing dropPrefix :: String -> String -> Maybe String dropPrefix pref s = case isPrefixOf pref s of True -> Just (drop (length pref) s) False -> Nothing -} cond ifF _ifT False = ifF cond _ifF ifT True = ifT debianize force pkgDesc flags compiler tgtPfx = mapM_ removeIfExists ["debian/control", "debian/changelog"] >> updateDebianization force pkgDesc flags compiler tgtPfx removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x)) removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x)) removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x updateDebianization :: Bool -- ^whether to forcibly create file -> PackageDescription -- ^info from the .cabal file -> Flags -- ^command line yflags -> 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 (const . showLicense . license $ pkgDesc) id debianMaintainer <- getDebianMaintainer flags >>= maybe (error "Missing value for --maintainer") return controlUpdate (tgtPfx "control") flags compiler debianMaintainer pkgDesc changelogUpdate (tgtPfx "changelog") debianMaintainer pkgDesc date writeFile (tgtPfx "rules") (cdbsRules pkgDesc) getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True}) writeFile (tgtPfx "compat") "7" -- should this be hardcoded, or automatically read from /var/lib/dpkg/status? writeFile (tgtPfx "copyright") copyright -- The dev postinst and prerm files are generated by haskell-devscripts via cdbs. return () {- 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 ", 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 <- 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] ++ [comments] {- ++ devrules ++ profrules -} )) where header = ["#!/usr/bin/make -f", "include /usr/share/cdbs/1/rules/debhelper.mk", "include /usr/share/cdbs/1/class/hlibrary.mk"] comments = ["# How to install an extra file into the documentation package", "#binary-fixup/libghc6-" ++ libName ++ "-doc::", "#\techo \"Some informative text\" > debian/libghc6-" ++ libName ++ "-doc/usr/share/doc/libghc6-" ++ libName ++ "-doc/AnExtraDocFile"] {- devrules = case (library pkgDesc, executables pkgDesc) of (_, []) -> [] (_, execs) -> [["binary-fixup/" ++ (debianDevelPackageName libName) ++ "::"] ++ concat (map (\ exec -> ["\tmkdir -p debian/" ++ exeName exec ++ "/usr/bin", "\tmv debian/" ++ (debianDevelPackageName libName) ++ "/usr/lib/haskell-packages/ghc6/bin/" ++ exeName exec ++ " debian/" ++ exeName exec ++ "/usr/bin"]) (executables pkgDesc))] profrules = case (library pkgDesc, executables pkgDesc) of (_, []) -> [] (_, execs) -> [["binary-fixup/" ++ (debianProfilingPackageName libName) ++ "::"] ++ map (\ exec -> "\trm debian/" ++ (debianProfilingPackageName libName) ++ "/usr/lib/haskell-packages/ghc6/bin/" ++ exeName exec) (executables pkgDesc)] -} libName = unPackageName . pkgName . package $ pkgDesc 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 = builtIns compiler >>= \bundled -> try (readFile path) >>= either (\ _ -> 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 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 ++ map executableSpec (executables pkgDesc))} where --buildDepsIndep = "" sourceSpec = Paragraph ([Field ("Source", " " ++ debianSourcePackageName pkgDesc), Field ("Priority", " " ++ "optional"), Field ("Section", " " ++ "misc"), Field ("Maintainer", " " ++ debianMaintainer), Field ("Build-Depends", " " ++ showDeps' "Build-Depends:" debianBuildDeps), Field ("Build-Depends-Indep", " " ++ showDeps' "Build-Depends-Indep:" debianBuildDepsIndep), --Field ("Build-Depends-Indep", " " ++ buildDepsIndep), Field ("Standards-Version", " " ++ "3.8.1")] ++ list [] (\ s -> [Field ("Homepage", " " ++ s)]) (homepage pkgDesc)) executableSpec executable = Paragraph [Field ("Package", " " ++ map toLower (exeName executable)), 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" "-dev"] else [] profileLibrarySpecs = if debLibProf flags && isJust (library pkgDesc) then [librarySpec "any" "-prof"] else [] docLibrarySpecs = if isJust (library pkgDesc) then [docSpecsParagraph] else [] docSpecsParagraph = Paragraph [Field ("Package", " " ++ debianDocumentationPackageName (unPackageName . pkgName . package $ pkgDesc)), Field ("Architecture", " " ++ "all"), Field ("Section", " " ++ "doc"), Field ("Depends", " " ++ showDeps' "Depends:" ([[D.Rel "${haskell:Depends}" Nothing Nothing], [D.Rel "${misc:Depends}" Nothing Nothing]] ++ libraryDependencies "-doc")), Field ("Description", " " ++ libraryDescription "-doc")] librarySpec arch suffix = Paragraph [Field ("Package", " " ++ prefix ++ map toLower (unPackageName . pkgName . package $ pkgDesc) ++ suffix), Field ("Architecture", " " ++ arch), Field ("Section", " " ++ "haskell"), Field ("Depends", " " ++ showDeps' "Depends:" ([[D.Rel "${haskell:Depends}" Nothing Nothing], [D.Rel "${misc:Depends}" Nothing Nothing]] ++ libraryDependencies suffix)), Field ("Description", " " ++ libraryDescription suffix)] where prefix = case suffix of "-dev" -> "libghc6-" "-prof" -> "libghc6-" -- "-doc" -> docPrefix (unPackageName . pkgName . package $ pkgDesc) _ -> error $ "Unknown suffix: " ++ suffix libraryDependencies :: String -> D.Relations libraryDependencies "-dev" = [] libraryDependencies "-prof" = [[D.Rel (debianDevelPackageName (unPackageName . pkgName . package $ pkgDesc)) Nothing Nothing]] libraryDependencies "-doc" = [[D.Rel "ghc6-doc" Nothing Nothing]] libraryDependencies suffix = error $ "Unexpected library package name suffix: " ++ show suffix -- The haskell-cdbs package contains the hlibrary.mk file with -- the rules for building haskell packages. debianBuildDeps :: D.Relations debianBuildDeps = [[D.Rel "debhelper" (Just (D.GRE (parseDebianVersion "7.0"))) Nothing], [D.Rel "haskell-devscripts" (Just (D.GRE (parseDebianVersion "0.6.15+nmu7"))) Nothing], [D.Rel "cdbs" Nothing Nothing], [D.Rel "ghc6" (Just (D.GRE (parseDebianVersion "6.8"))) Nothing]] ++ (if debLibProf flags then [[D.Rel "ghc6-prof" Nothing Nothing]] else []) ++ (concat . map (debianDependencies bundled compiler buildDependencies) . allBuildDepends $ pkgDesc) debianBuildDepsIndep :: D.Relations debianBuildDepsIndep = [[D.Rel "ghc6-doc" Nothing Nothing], [D.Rel "haddock" Nothing Nothing]] debianDescription = (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 "-prof" = debianDescription ++ "\n .\n This package contains the libraries compiled with profiling enabled." libraryDescription "-dev" = debianDescription ++ "\n .\n This package contains the normal library files." libraryDescription "-doc" = debianDescription ++ "\n .\n This package contains the documentation files." libraryDescription x = error $ "Unexpected library package name suffix: " ++ show x showDeps xss = intercalate ", " (map (intercalate " | " . map show) xss) showDeps' prefix xss = intercalate (",\n " ++ prefix') (map (intercalate " | " . map show) xss) where prefix' = map (\ _ -> ' ') prefix -- |Debian packages don't have per binary package build dependencies, -- so we just gather them all up here. allBuildDepends pkgDesc = nub $ buildDepends pkgDesc ++ concat (map buildTools (allBuildInfo pkgDesc) ++ map pkgconfigDepends (allBuildInfo pkgDesc)) -- Turn a cabal dependency into a list of debian relations. If a -- library is required as a build dependency we need the profiling -- version, which pulls in the regular version, and we need the -- documentation so the cross references can be resolved. debianDependencies :: [Bundled] -> Compiler -> (Compiler -> Dependency -> D.Relations) -> Dependency -> D.Relations debianDependencies bundled compiler toDebRels dep | isBundled bundled compiler dep = [] debianDependencies _ compiler toDebRels dep = toDebRels compiler dep changelogUpdate :: FilePath -> String -> PackageDescription -> String -> IO () changelogUpdate path debianMaintainer pkgDesc date = try (readFile path) >>= either (const (writeFile path log)) (const (writeFile (path ++ ".new") log)) where log = changelog debianMaintainer pkgDesc date changelog :: String -> PackageDescription -> String -> String changelog debianMaintainer pkgDesc date = show (Entry { logPackage = debianSourcePackageName pkgDesc , logVersion = debianVersionNumber pkgDesc , logDists = [parseReleaseName "unstable"] , logUrgency = "low" , logComments = " * Debianization generated by cabal-debian\n\n" , logWho = debianMaintainer , logDate = date }) unPackageName :: PackageName -> String unPackageName (PackageName s) = s debianSourcePackageName :: PackageDescription -> String debianSourcePackageName pkgDesc = "haskell-" ++ map toLower (unPackageName . pkgName . package $ pkgDesc) debianProfilingPackageName :: String -> String debianProfilingPackageName x = "libghc6-" ++ map toLower x ++ "-prof" debianDevelPackageName :: String -> String debianDevelPackageName x = "libghc6-" ++ map toLower x ++ "-dev" --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 -- The profiling packages depend on the other profiling packages. -- FIXME: These should have version dependencies. profilingDependencies :: Compiler -> Dependency -> D.Relations profilingDependencies compiler dep@(Dependency (PackageName name) ranges) = concat (map (\ x -> debianRelations x ranges) names) where names = if isLibrary compiler dep then [debianProfilingPackageName name] else [] -- The development packages depend on the other development packages, -- the ones they were built with. FIXME: These should have version -- dependencies. develDependencies :: Compiler -> Dependency -> D.Relations develDependencies compiler dep@(Dependency (PackageName name) ranges) = concat (map (\ x -> debianRelations x ranges) names) where names = if isLibrary compiler dep then [debianDevelPackageName name] else [] -- The build dependencies for a package include the profiling -- libraries and the documentation packages, used for creating cross -- references. buildDependencies :: Compiler -> Dependency -> D.Relations buildDependencies compiler dep@(Dependency (PackageName name) ranges) = concat (map (\ x -> debianRelations x ranges) names) where names = if isLibrary compiler dep then [ debianProfilingPackageName name , debianDocumentationPackageName name ] else [name] -- The documentation dependencies for a package include the documentation -- package for any libraries which are build dependencies, so we have access -- to all the cross references. docDependencies :: Compiler -> Dependency -> D.Relations docDependencies compiler dep@(Dependency (PackageName name) ranges) = concat (map (\ x -> debianRelations x ranges) names) where names = if isLibrary compiler dep then [debianDocumentationPackageName name] else [] debianRelations :: String -> VersionRange -> D.Relations debianRelations name range = map (merge . map (relation name)) (canon range) where -- A debian dependency list is always a list of or-relations -- which are anded. This function turns the more freeform cabal -- relations into that format. canon :: VersionRange -> [[VersionRange]] canon (IntersectVersionRanges a b) = canon a ++ canon b canon (UnionVersionRanges a b) = map concat (cartesianProduct [canon a, canon b]) canon x = [[x]] -- Turn simple Cabal relations into Debian relations relation name AnyVersion = D.Rel name Nothing Nothing relation name (ThisVersion version) = D.Rel name (Just (D.EEQ (parseDebianVersion (showVersion version)))) Nothing relation name (EarlierVersion version) = D.Rel name (Just (D.SLT (parseDebianVersion (showVersion version)))) Nothing relation name (LaterVersion version) = D.Rel name (Just (D.SGR (parseDebianVersion (showVersion version)))) Nothing relation _ _ = error $ "Invalid argument to debianRelations: " ++ show range -- Merge some combinations that frequently show up. merge (D.Rel name1 (Just (D.EEQ ver1)) arch1 : D.Rel name2 (Just (D.SLT ver2)) arch2 : xs) | name1 == name2 && ver1 == ver2 && arch1 == arch2 = merge (D.Rel name1 (Just (D.LTE ver1)) arch1 : xs) merge (D.Rel name1 (Just (D.EEQ ver1)) arch1 : D.Rel name2 (Just (D.SGR ver2)) arch2 : xs) | name1 == name2 && ver1 == ver2 && arch1 == arch2 = merge (D.Rel name1 (Just (D.GRE ver1)) arch1 : xs) merge (x : xs) = x : merge xs merge [] = [] debianDocumentationPackageName :: String -> String debianDocumentationPackageName x = docPrefix (map toLower x) ++ map toLower x ++ "-doc" -- | cartesianProduct [[1,2,3], [4,5],[6]] -> [[1,4,6],[1,5,6],[2,4,6],[2,5,6],[3,4,6],[3,5,6]] cartesianProduct :: [[a]] -> [[a]] cartesianProduct = sequence -- | 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"