{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections, TypeSynonymInstances #-} {-# OPTIONS -Wall -fno-warn-name-shadowing #-} -- | -- 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 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 -, -- 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-.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: -- 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 ", 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"