diff --git a/CabalDebian.hs b/CabalDebian.hs deleted file mode 100644 --- a/CabalDebian.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | --- Module : CabalDebian --- Copyright : David Fox 2008 --- --- Maintainer : David Fox --- Stability : alpha --- Portability : portable --- --- Explanation: Main entry point for generating Debianizations 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 Main where - -import qualified Distribution.Package.Debian.Main as Debian - -main :: IO () - -main = Debian.main diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs deleted file mode 100644 --- a/Distribution/Package/Debian.hs +++ /dev/null @@ -1,752 +0,0 @@ -{-# 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 Debug.Trace - -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.Either (partitionEithers) -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, parseLog) -import Debian.Time (getCurrentLocalRFC822Time) -import Debian.Version (DebianVersion, prettyDebianVersion) -import Debian.Version.String -import System.Cmd (system) -import System.Directory -import System.Exit (ExitCode(..)) -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.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.Dependencies (PackageType(..), debianExtraPackageName, debianUtilsPackageName, debianSourcePackageName, debianDocPackageName, - {-DebianBinPackageName,-} debianDevPackageName, debianProfPackageName) -import Distribution.Package.Debian.Relations (versionSplits) -import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..)) ---import qualified Distribution.Compat.ReadP as ReadP ---import Distribution.Text ( Text(parse) ) -import Text.PrettyPrint.HughesPJ - -import Distribution.Package.Debian.Relations (buildDependencies, docDependencies, allBuildDepends, cabalDependencies) - -{- -_parsePackageId' :: ReadP.ReadP PackageIdentifier PackageIdentifier -_parsePackageId' = parseQuoted parse ReadP.<++ parse --} - -type DebMap = Map.Map D.BinPkgName (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 (D.BinPkgName (D.PkgName (stripWS name)), Just (parseDebianVersion (stripWS version)))) - _ -> return Nothing) >>= - return . Map.fromList . catMaybes - -(!) :: DebMap -> D.BinPkgName -> DebianVersion -m ! k = maybe (error ("No version number for " ++ (show . D.prettyBinPkgName $ 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 flags pkgDesc compiler debVersions control cabalPackages name - Debianize -> - debianize True pkgDesc flags compiler (debOutputDir flags) - UpdateDebianization -> - updateDebianization True pkgDesc flags compiler (debOutputDir flags) - Usage -> - error "Unexpected debAction: usage" - 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 (D.BinPkgName, DebianVersion) - , profDeb :: Maybe (D.BinPkgName, DebianVersion) - , docDeb :: Maybe (D.BinPkgName, 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 :: Flags - -> 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 flags 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 (show . D.prettyBinPkgName . 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 = fmap (\ (D.BinPkgName (D.PkgName x)) -> "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 flags 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 flags 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 flags 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 flags pkgDesc)) - buildDepNames :: [D.BinPkgName] - 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 = fmap (D.BinPkgName . D.PkgName) $ listToMaybe (filter (isSuffixOf "-dev") debNames) - profDebName = fmap (D.BinPkgName . D.PkgName) $ listToMaybe (filter (isSuffixOf "-prof") debNames) - docDebName = fmap (D.BinPkgName . D.PkgName) $ 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 D.BinPkgName)) 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 D.BinPkgName)) -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 . map (D.BinPkgName . D.PkgName)) $ 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 D.BinPkgName)) IO (Maybe D.BinPkgName) -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"] >> - 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" - createDirectoryIfMissing True "debian/source" - 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 - replaceFile (tgtPfx "source/format") (sourceFormat flags) - replaceFile (tgtPfx "watch") ("version=3\nopts=\"downloadurlmangle=s|archive/([\\w\\d_-]+)/([\\d\\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\\\nfilenamemangle=s|(.*)/$|" ++ pkgname ++ "-$1.tar.gz|\" \\\n http://hackage.haskell.org/packages/archive/" ++ pkgname ++ " \\\n ([\\d\\.]*\\d)/\n") - -- The dev postinst and prerm files are generated by haskell-devscripts via cdbs. - return () - where - PackageName pkgname = pkgName . package $ pkgDesc - -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 = " ++ (show (D.prettyBinPkgName (debianExtraPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc))))))))), - "", - "include /usr/share/cdbs/1/rules/debhelper.mk", - "include /usr/share/cdbs/1/class/hlibrary.mk"] - execs = - case map exeName (executables pkgDesc) ++ dataFiles 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/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ ":: build-ghc-stamp" - , "binary-fixup/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ "::" ] ++ - map (\ exe -> - let src = "dist-ghc/build/" ++ exe ++ "/" ++ exe - dst = "debian/" ++ (show . D.prettyBinPkgName $ utilsDeb) ++ "/usr/bin/" ++ exe in - "\tinstall -m 755 -s -D " ++ src ++ " " ++ dst ++ " || true") (map exeName (executables pkgDesc)) ++ - map (\ file -> - let dst = "debian" (show . D.prettyBinPkgName $ utilsDeb) "usr/share" libDir file in - "\tinstall -m 644 -D " ++ file ++ " " ++ dst ++ " || true") (dataFiles pkgDesc) - comments = - ["# How to install an extra file into the documentation package", - "#binary-fixup/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "::", - "#\techo \"Some informative text\" > debian/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "/usr/share/doc/" ++ (show . D.prettyBinPkgName $ docDeb) ++ "/AnExtraDocFile"] - p = pkgName . package $ pkgDesc - v = pkgVersion . package $ pkgDesc - libDir = unPackageName p ++ "-" ++ showVersion v - docDeb = debianDocPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))) - utilsDeb = debianUtilsPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))) - --exeDeb e = debianExtraPackageName (PackageName (exeName e)) Nothing - -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 = - try (readFile path) >>= - either (\ (_ :: SomeException) -> writeFile path (show newCtl)) (\ s -> writeFile (path ++ ".new") $! show (merge newCtl (oldCtl s))) - where - newCtl = control flags 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 -> Compiler -> String -> PackageDescription -> Control -control flags compiler debianMaintainer pkgDesc = - -- trace ("allBuildDepends " ++ show flags ++ " -> " ++ show (allBuildDepends flags pkgDesc)) $ - Control {unControl = - ([sourceSpec] ++ - develLibrarySpecs ++ - profileLibrarySpecs ++ - docLibrarySpecs ++ - (case map exeName (executables pkgDesc) ++ dataFiles pkgDesc of - [] -> [] - -- [e] -> [utilsSpec (debianName Extra (PackageName (exeName e)) Nothing)] - _ -> [utilsSpec (show . D.prettyBinPkgName $ debianUtilsPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))]))} - where - --buildDepsIndep = "" - sourceSpec = - Paragraph - ([Field ("Source", " " ++ (show . D.prettySrcPkgName $ debianSourcePackageName versionSplits (pkgName . package $ pkgDesc) (Just (D.EEQ (parseDebianVersion (showVersion (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.3"), - Field ("Homepage", - " " ++ - if homepage pkgDesc == "" - then "http://hackage.haskell.org/package/" ++ - unPackageName (pkgName $ package pkgDesc) - else homepage pkgDesc)]) - rel x = [D.Rel (D.BinPkgName (D.PkgName 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 (D.BinPkgName (D.PkgName "${shlibs:Depends}")) Nothing Nothing], - [D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing], - [D.Rel (D.BinPkgName (D.PkgName "${misc:Depends}")) Nothing Nothing]]), - Field ("Description", " " ++ maybe debianDescription (const executableDescription) (library pkgDesc))] - develLibrarySpecs = if isJust (library pkgDesc) then [librarySpec "any" Development debianDevPackageName] else [] - profileLibrarySpecs = if debLibProf flags && isJust (library pkgDesc) then [librarySpec "any" Profiling debianProfPackageName] else [] - docLibrarySpecs = if isJust (library pkgDesc) && rpmHaddock flags then [docSpecsParagraph] else [] - docSpecsParagraph = - Paragraph - [Field ("Package", " " ++ (show . D.prettyBinPkgName $ debianDocPackageName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))), - Field ("Architecture", " " ++ "all"), - Field ("Section", " " ++ "doc"), - Field ("Depends", " " ++ showDeps' "Depends:" [[D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing], - [D.Rel (D.BinPkgName (D.PkgName "${misc:Depends}")) Nothing Nothing]]), - Field ("Recommends", " " ++ "${haskell:Recommends}"), - Field ("Suggests", " " ++ "${haskell:Suggests}"), - Field ("Description", " " ++ libraryDescription Documentation)] - librarySpec arch typ debianName = - Paragraph - [Field ("Package", " " ++ (show . D.prettyBinPkgName $ debianName versionSplits (pkgName (package pkgDesc)) (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion (package pkgDesc)))))))), - Field ("Architecture", " " ++ arch), - Field ("Depends", " " ++ showDeps' "Depends:" ( - (if typ == Development - then [[D.Rel (D.BinPkgName (D.PkgName "${shlibs:Depends}")) Nothing Nothing]] ++ map (\ x -> [D.Rel (D.BinPkgName (D.PkgName x)) Nothing Nothing]) (extraDevDeps flags) - else []) ++ - [[D.Rel (D.BinPkgName (D.PkgName "${haskell:Depends}")) Nothing Nothing], - [D.Rel (D.BinPkgName (D.PkgName "${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 (D.BinPkgName (D.PkgName "debhelper")) (Just (D.GRE (parseDebianVersion "7.0"))) Nothing], - [D.Rel (D.BinPkgName (D.PkgName "haskell-devscripts")) (Just (D.GRE (parseDebianVersion "0.8"))) Nothing], - [D.Rel (D.BinPkgName (D.PkgName "cdbs")) Nothing Nothing], - [D.Rel (D.BinPkgName (D.PkgName "ghc")) Nothing Nothing]] ++ - (if debLibProf flags then [[D.Rel (D.BinPkgName (D.PkgName "ghc-prof")) Nothing Nothing]] else []) ++ - (concat . map (buildDependencies flags compiler) . allBuildDepends flags $ pkgDesc) - debianBuildDepsIndep :: D.Relations - debianBuildDepsIndep = - nub $ - [[D.Rel (D.BinPkgName (D.PkgName "ghc-doc")) Nothing Nothing]] ++ - (concat . map (docDependencies flags compiler) . allBuildDepends flags $ 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 --} - -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 = - read >>= replace - where - read :: IO ([[String]], [ChangeLogEntry]) - read = try (readFile path) >>= return . either (\ (e :: SomeException) -> ([[show e]], [])) (partitionEithers . parseLog) - replace :: ([[String]], [ChangeLogEntry]) -> IO () - replace (errs, entries) = - do when (not (null errs)) (hPutStrLn stderr (intercalate "\n " ("Errors reading changelog:" : concat errs))) - let entries' = dropWhile (\ entry -> logVersion entry >= logVersion log) entries - replaceFile path (intercalate "\n" (map (render . prettyEntry) (log : entries'))) - log = changelog flags debianMaintainer pkgDesc date - -{- -changelog :: Flags -> String -> PackageDescription -> String -> String -changelog flags debianMaintainer pkgDesc date = - render . prettyEntry $ changelog' flags debianMaintainer pkgDesc date --} - -changelog :: Flags -> String -> PackageDescription -> String -> ChangeLogEntry -changelog flags debianMaintainer pkgDesc date = - Entry { logPackage = (show . D.prettySrcPkgName $ debianSourcePackageName versionSplits (pkgName . package $ pkgDesc) (Just (D.EEQ (parseDebianVersion (showVersion (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) (\ d -> if older d s then error ("Version from --deb-version (" ++ show d ++ ") is older than hackage version (" ++ show s ++ "), maybe you need to unpin this package?") else d) (debVersion flags) - g s = maybe "" (\ n -> show n ++ ":") (Map.lookup (pkgName (package pkgDesc)) (epochMap flags)) ++ s ++ revision flags - older debv cabv = parseDebianVersion debv < parseDebianVersion cabv - -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" diff --git a/Distribution/Package/Debian/Bundled.hs b/Distribution/Package/Debian/Bundled.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Bundled.hs +++ /dev/null @@ -1,323 +0,0 @@ --- | --- Module : Distribution.Package.Debian.Bundled --- Copyright : David Fox 2008 --- --- Maintainer : David Fox --- Stability : alpha --- Portability : portable --- --- Determine whether a specific version of a Haskell package is --- bundled with into this particular version of the given compiler. - --- This software may be used and distributed according to the terms of --- the GNU General Public License, incorporated herein by reference. -{-# LANGUAGE StandaloneDeriving #-} -module Distribution.Package.Debian.Bundled - ( ghcBuiltIn - ) where - -import qualified Data.Map as Map -import Data.Set (fromList, member) -import Data.Version (Version(..)) -import Debian.Relation.ByteString() -import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-}) -import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-}) -import System.Exit (ExitCode(..)) - -type Bundled = (CompilerFlavor, Version, [PackageIdentifier]) - --- |Return a list of built in packages for the compiler in an environment. --- ghcBuiltIns :: FilePath -> IO [PackageIdentifier] --- ghcBuiltIns root = --- fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>= --- return . map parsePackageIdentifier . words . unpack . fst . collectStdout --- where --- parsePackageIdentifier s = --- let (v', n') = break (== '-') (reverse s) --- (v, n) = (reverse (tail n'), reverse v') in --- PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) []) - -ghcBuiltIns :: Compiler -> Bundled -ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) = - case Map.lookup compilerVersion - (Map.fromList [ (Version [7,4,1] [], (GHC, Version [7,4,1] [], ghc741BuiltIns)) - , (Version [7,4,0,20111219] [], (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns)) - , (Version [7,4,0,20120108] [], (GHC, Version [7,4,0,20120108] [], ghc740BuiltIns)) - , (Version [7,2,2] [], (GHC, Version [7,2,2] [], ghc721BuiltIns)) - , (Version [7,2,1] [], (GHC, Version [7,2,1] [], ghc721BuiltIns)) - , (Version [7,0,4] [], (GHC, Version [7,0,4] [], ghc701BuiltIns)) - , (Version [7,0,3] [], (GHC, Version [7,0,3] [], ghc701BuiltIns)) - , (Version [7,0,1] [], (GHC, Version [7,0,1] [], ghc701BuiltIns)) - , (Version [6,8,3] [], (GHC, Version [6,8,3] [], ghc683BuiltIns)) - , (Version [6,8,2] [], (GHC, Version [6,8,2] [], ghc682BuiltIns)) - , (Version [6,8,1] [], (GHC, Version [6,8,1] [], ghc681BuiltIns)) - , (Version [6,6,1] [], (GHC, Version [6,6,1] [], ghc661BuiltIns)) - , (Version [6,6] [], (GHC, Version [6,6] [], ghc66BuiltIns)) ]) of - Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion - Just x -> x - -ghcBuiltIn :: Compiler -> PackageName -> Bool -ghcBuiltIn compiler package = - Data.Set.member - package - (Data.Set.fromList - (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -} - (_, _, xs) = ghcBuiltIns compiler in map pkgName xs)) - -v :: String -> [Int] -> PackageIdentifier -v n x = PackageIdentifier (PackageName n) (Version x []) - --- | Packages bundled with 7.4.0.20111219-2. -ghc741BuiltIns :: [PackageIdentifier] -ghc741BuiltIns = [ - v "Cabal" [1,14,0], - v "array" [0,4,0,0], - v "base" [4,5,0,0], - v "bin-package-db" [0,0,0,0], - v "binary" [0,5,1,0], - v "bytestring" [0,9,2,1], - v "containers" [0,4,2,1], - v "deepseq" [1,3,0,0], - v "directory" [1,1,0,2], - v "extensible-exceptions" [0,1,1,4], - v "filepath" [1,3,0,0], - v "ghc" [7,4,1], - v "ghc-prim" [0,2,0,0], - v "haskell2010" [1,1,0,1], - v "haskell98" [2,0,0,1], - v "hoopl" [3,8,7,2], - v "hpc" [0,5,1,1], - v "integer-gmp" [0,4,0,0], - v "old-locale" [1,0,0,4], - v "old-time" [1,1,0,0], - v "pretty" [1,1,1,0], - v "process" [1,1,0,1], - v "rts" [1,0], - v "template-haskell" [2,7,0,0], - v "time" [1,4], - v "unix" [2,5,1,0] ] - --- | Packages bundled with 7.4.0.20111219-2. -ghc740BuiltIns :: [PackageIdentifier] -ghc740BuiltIns = [ - v "Cabal" [1,14,0], - v "array" [0,4,0,0], - v "base" [4,5,0,0], - v "bin-package-db" [0,0,0,0], - v "binary" [0,5,1,0], - v "bytestring" [0,9,2,1], - v "containers" [0,4,2,1], - v "deepseq" [1,3,0,0], - v "directory" [1,1,0,2], - v "extensible-exceptions" [0,1,1,4], - v "filepath" [1,3,0,0], - v "ghc" [7,4,0,20111219], - v "ghc-prim" [0,2,0,0], - v "haskell2010" [1,1,0,1], - v "haskell98" [2,0,0,1], - v "hoopl" [3,8,7,2], - v "hpc" [0,5,1,1], - v "integer-gmp" [0,4,0,0], - v "old-locale" [1,0,0,4], - v "old-time" [1,1,0,0], - v "pretty" [1,1,1,0], - v "process" [1,1,0,1], - v "rts" [1,0], - v "template-haskell" [2,7,0,0], - v "time" [1,4], - v "unix" [2,5,1,0] ] - -ghc721BuiltIns :: [PackageIdentifier] -ghc721BuiltIns = [ - v "Cabal" [1,12,0], - v "array" [0,3,0,3], - v "base" [4,4,0,0], - v "bin-package-db" [0,0,0,0], - v "binary" [0,5,0,2], - v "bytestring" [0,9,2,0], - v "containers" [0,4,1,0], - v "directory" [1,1,0,1], - v "extensible-exceptions" [0,1,1,3], - v "filepath" [1,2,0,1], - v "ghc" [7,2,1], - -- ghc-binary renamed to binary - v "ghc-prim" [0,2,0,0], - v "haskell2010" [1,1,0,0], - v "haskell98" [2,0,0,0], - v "hoopl" [3,8,7,1], -- new - v "hpc" [0,5,1,0], - v "integer-gmp" [0,3,0,0], - v "old-locale" [1,0,0,3], - v "old-time" [1,0,0,7], - v "pretty" [1,1,0,0], - v "process" [1,1,0,0], - -- random removed - v "rts" [1,0], - v "template-haskell" [2,6,0,0], - v "time" [1,2,0,5], - v "unix" [2,5,0,0] ] - -ghc701BuiltIns :: [PackageIdentifier] -ghc701BuiltIns = [ - v "Cabal" [1,10,0,0], - v "array" [0,3,0,2], - v "base" [4,3,0,0], - v "bin-package-db" [0,0,0,0], - v "bytestring" [0,9,1,8], - v "containers" [0,4,0,0], - v "directory" [1,1,0,0], - v "extensible-exceptions" [0,1,1,2], - v "filepath" [1,2,0,0], - v "ghc" [7,0,1], - v "ghc-binary" [0,5,0,2], - v "ghc-prim" [0,2,0,0], - v "haskell2010" [1,0,0,0], - v "haskell98" [1,1,0,0], - v "hpc" [0,5,0,6], - v "integer-gmp" [0,2,0,2], - v "old-locale" [1,0,0,2], - v "old-time" [1,0,0,6], - v "pretty" [1,0,1,2], - v "process" [1,0,1,4], - v "random" [1,0,0,3], - v "rts" [1,0], - v "template-haskell" [2,5,0,0], - v "time" [1,2,0,3], - v "unix" [2,4,1,0] - ] - -ghc683BuiltIns :: [PackageIdentifier] -ghc683BuiltIns = ghc682BuiltIns - -ghc682BuiltIns :: [PackageIdentifier] -ghc682BuiltIns = [ - v "Cabal" [1,2,3,0], - v "array" [0,1,0,0], - v "base" [3,0,1,0], - v "bytestring" [0,9,0,1], - v "containers" [0,1,0,1], - v "directory" [1,0,0,0], - v "filepath" [1,1,0,0], - v "ghc" [6,8,2,0], - v "haskell98" [1,0,1,0], - v "hpc" [0,5,0,0], - v "old-locale" [1,0,0,0], - v "old-time" [1,0,0,0], - v "packedstring" [0,1,0,0], - v "pretty" [1,0,0,0], - v "process" [1,0,0,0], - v "random" [1,0,0,0], - v "readline" [1,0,1,0], - v "template-haskell" [2,2,0,0], - v "unix" [2,3,0,0] - ] - -ghc681BuiltIns :: [PackageIdentifier] -ghc681BuiltIns = [ - v "base" [3,0,0,0], - v "Cabal" [1,2,2,0], - v "GLUT" [2,1,1,1], - v "HGL" [3,2,0,0], - v "HUnit" [1,2,0,0], - v "OpenAL" [1,3,1,1], - v "OpenGL" [2,2,1,1], - v "QuickCheck" [1,1,0,0], - v "X11" [1,2,3,1], - v "array" [0,1,0,0], - v "bytestring" [0,9,0,1], - v "cgi" [3001,1,5,1], - v "containers" [0,1,0,0], - v "directory" [1,0,0,0], - v "fgl" [5,4,1,1], - v "filepatch" [1,1,0,0], - v "ghc" [6,8,1,0], - v "haskell-src" [1,0,1,1], - v "haskell98" [1,0,1,0], - v "hpc" [0,5,0,0], - v "html" [1,0,1,1], - v "mtl" [1,1,0,0], - v "network" [2,1,0,0], - v "old-locale" [1,0,0,0], - v "old-time" [1,0,0,0], - v "packedstring" [0,1,0,0], - v "parallel" [1,0,0,0], - v "parsec" [2,1,0,0], - v "pretty" [1,0,0,0], - v "process" [1,0,0,0], - v "random" [1,0,0,0], - v "readline" [1,0,1,0], - v "regex-base" [0,72,0,1], - v "regex-compat" [0,71,0,1], - v "regex-posix" [0,72,0,1], - v "stm" [2,1,1,0], - v "template-haskell" [2,2,0,0], - v "time" [1,1,2,0], - v "unix" [2,2,0,0], - v "xhtml" [3000,0,2,1] - ] - -ghc661BuiltIns :: [PackageIdentifier] -ghc661BuiltIns = [ - v "base" [2,1,1], - v "Cabal" [1,1,6,2], - v "cgi" [3001,1,1], - v "fgl" [5,4,1], - v "filepath" [1,0], - v "ghc" [6,6,1], - v "GLUT" [2,1,1], - v "haskell98" [1,0], - v "haskell-src" [1,0,1], - v "HGL" [3,1,1], - v "html" [1,0,1], - v "HUnit" [1,1,1], - v "mtl" [1,0,1], - v "network" [2,0,1], - v "OpenAL" [1,3,1], - v "OpenGL" [2,2,1], - v "parsec" [2,0], - v "QuickCheck" [1,0,1], - v "readline" [1,0], - v "regex-base" [0,72], - v "regex-compat" [0,71], - v "regex-posix" [0,71], - v "rts" [1,0], - v "stm" [2,0], - v "template-haskell" [2,1], - v "time" [1,1,1], - v "unix" [2,1], - v "X11" [1,2,1], - v "xhtml" [3000,0,2] - ] - -ghc66BuiltIns :: [PackageIdentifier] -ghc66BuiltIns = [ - v "base" [2,0], - v "Cabal" [1,1,6], - v "cgi" [2006,9,6], - v "fgl" [5,2], - v "ghc" [6,6], - v "GLUT" [2,0], - v "haskell98" [1,0], - v "haskell-src" [1,0], - v "HGL" [3,1], - v "html" [1,0], - v "HTTP" [2006,7,7], - v "HUnit" [1,1], - v "mtl" [1,0], - v "network" [2,0], - v "OpenAL" [1,3], - v "OpenGL" [2,1], - v "parsec" [2,0], - v "QuickCheck" [1,0], - v "readline" [1,0], - v "regex-base" [0,71], - v "regex-compat" [0,71], - v "regex-posix" [0,71], - v "rts" [1,0], - v "stm" [2,0], - v "template-haskell" [2,0], - v "time" [1,0], - v "unix" [1,0], - v "X11" [1,1], - v "xhtml" [2006,9,13] - ] diff --git a/Distribution/Package/Debian/Dependencies.hs b/Distribution/Package/Debian/Dependencies.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Dependencies.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving #-} -{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-} -module Distribution.Package.Debian.Dependencies - ( PackageType(..) - , VersionSplits(..) - , dependencies - , mkPkgName - , invertVersionRange - -- , debianName - , debianSourcePackageName - , DebianBinPackageName - , debianDevPackageName - , debianProfPackageName - , debianDocPackageName - , debianExtraPackageName - , debianUtilsPackageName - ) where - -import Data.Char (toLower) -import Data.Function (on) -import Data.List (intersperse, minimumBy) -import qualified Data.Map as Map -import Data.Maybe (catMaybes) -import Data.Version (showVersion) -import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(PkgName), VersionReq(..), SrcPkgName(..)) -import qualified Debian.Relation as D -import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion) -import Distribution.Package (PackageName(PackageName)) -import Distribution.Package.Debian.Bundled (ghcBuiltIn) -import Distribution.Package.Debian.Interspersed (Interspersed(..)) -import Distribution.Package.Debian.Setup (Flags(..)) -import Distribution.Simple.Compiler (Compiler(..)) -import Distribution.Version (Version(..), VersionRange(..), anyVersion, foldVersionRange', intersectVersionRanges, unionVersionRanges, - laterVersion, orLaterVersion, earlierVersion, orEarlierVersion, fromVersionIntervals, toVersionIntervals, withinVersion, - isNoVersion, asVersionIntervals, mkVersionIntervals, LowerBound(..), UpperBound(..), Bound(..)) -import Text.PrettyPrint (Doc, text, hcat , (<>), empty) - -data PackageType = Source | Development | Profiling | Documentation | Utilities | Extra deriving (Eq, Show) - -data VersionSplits - = VersionSplits { - packageName :: PackageName - , oldestPackage :: BinPkgName - , splits :: [(Version, BinPkgName)] -- Assumed to be in version number order - } - -instance Interspersed VersionSplits BinPkgName Version where - leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance" - leftmost (VersionSplits {oldestPackage = p}) = p - pairs (VersionSplits {splits = xs}) = xs - --- | Turn a cabal dependency into debian dependencies. The result --- needs to correspond to a single debian package to be installed, --- so we will return just an OrRelation. -dependencies :: Flags -> Compiler -> (PackageType -> [VersionSplits]) -> PackageType -> Either BinPkgName PackageName -> VersionRange -> Relations -dependencies flags compiler versionSplits typ (Left name) cabalRange = [[D.Rel name Nothing Nothing]] -dependencies flags compiler versionSplits typ (Right name@(PackageName string)) cabalRange = - map doBundled $ convert' (canonical (Or (catMaybes (map convert alts)))) - where - - -- Compute a list of alternative debian dependencies for - -- satisfying a cabal dependency. The only caveat is that - -- we may need to distribute any "and" dependencies implied - -- by a version range over these "or" dependences. - alts :: [(BinPkgName, VersionRange)] - alts = case Map.lookup name (packageSplits versionSplits typ) of - -- If there are no splits for this package just return the single dependency for the package - Nothing -> [(mkPkgName string typ, cabalRange')] - -- If there are splits create a list of (debian package name, VersionRange) pairs - Just splits -> packageRangesFromVersionSplits splits - - convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation) - convert (dname, range) = - if isNoVersion range''' - then Nothing - else Just $ - foldVersionRange' - (Rel (D.Rel dname Nothing Nothing)) - (\ v -> Rel (D.Rel dname (Just (D.EEQ (dv v))) Nothing)) - (\ v -> Rel (D.Rel dname (Just (D.SGR (dv v))) Nothing)) - (\ v -> Rel (D.Rel dname (Just (D.SLT (dv v))) Nothing)) - (\ v -> Rel (D.Rel dname (Just (D.GRE (dv v))) Nothing)) - (\ v -> Rel (D.Rel dname (Just (D.LTE (dv v))) Nothing)) - (\ x y -> And [Rel (D.Rel dname (Just (D.GRE (dv x))) Nothing), Rel (D.Rel dname (Just (D.SLT (dv y))) Nothing)]) - (\ x y -> Or [x, y]) - (\ x y -> And [x, y]) - id - range''' - where - -- Choose the simpler of the two - range''' = canon (simpler range' range'') - -- Unrestrict the range for versions that we know don't exist for this debian package - range'' = canon (unionVersionRanges range' (invertVersionRange range)) - -- Restrict the range to the versions specified for this debian package - range' = intersectVersionRanges cabalRange' range - -- When we see a cabal equals dependency we need to turn it into - -- a wildcard because the resulting debian version numbers have - -- various suffixes added. - cabalRange' = - foldVersionRange' - anyVersion - withinVersion -- <- Here we are turning equals into wildcard - laterVersion - earlierVersion - orLaterVersion - orEarlierVersion - (\ lb ub -> intersectVersionRanges (orLaterVersion lb) (earlierVersion ub)) - unionVersionRanges - intersectVersionRanges - id - cabalRange - -- Convert a cabal version to a debian version, adding an epoch number if requested - dv v = parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (epochMap flags)) ++ showVersion v) - simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2] - -- Simplify a VersionRange - canon = fromVersionIntervals . toVersionIntervals - - -- If a package is bundled with the compiler we make the - -- compiler a substitute for that package. If we were to - -- specify the virtual package (e.g. libghc-base-dev) we would - -- have to make sure not to specify a version number. - doBundled :: [D.Relation] -> [D.Relation] - doBundled rels | ghcBuiltIn compiler name = rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing] - doBundled rels = rels - - compilerPackageName Documentation = D.BinPkgName (D.PkgName "ghc-doc") - compilerPackageName Profiling = D.BinPkgName (D.PkgName "ghc-prof") - compilerPackageName Development = D.BinPkgName (D.PkgName "ghc") - compilerPackageName _ = D.BinPkgName (D.PkgName "ghc") -- whatevs - -data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel {unRel :: a} deriving Show - --- | The intent of this class is to be similar to Show, but only one --- way, with no corresponding Read class. To put something in a --- pretty printing class implies that there is only one way to pretty --- print it, which is not an assumption made by Text.PrettyPrint. But --- in practice this is often good enough. -class Pretty x where - pretty :: x -> Doc - --- | return and of ors of rel -canonical :: Rels a -> Rels a -canonical (Rel rel) = And [Or [Rel rel]] -canonical (And rels) = And $ concatMap (unAnd . canonical) rels -canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels - -convert' :: Rels a -> [[a]] -convert' = map (map unRel . unOr) . unAnd . canonical - -packageSplits :: (PackageType -> [VersionSplits]) -> PackageType -> Map.Map PackageName VersionSplits -packageSplits versionSplits typ = - foldr (\ splits mp -> Map.insertWith multipleSplitsError (packageName splits) splits mp) - Map.empty - (versionSplits typ) - where - multipleSplitsError (VersionSplits {packageName = PackageName p}) _s2 = - error ("Multiple splits for package " ++ show p) - -packageRangesFromVersionSplits :: VersionSplits -> [(BinPkgName, VersionRange)] -packageRangesFromVersionSplits splits = - foldInverted (\ older dname newer more -> - (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more) - [] - splits - --- | Build a debian package name from a cabal package name and a --- debian package type. -mkPkgName :: String -> PackageType -> BinPkgName -mkPkgName base typ = - BinPkgName . PkgName $ prefix typ ++ map toLower base ++ suffix typ - where - suffix Source = "" - suffix Documentation = "-doc" - suffix Development = "-dev" - suffix Profiling = "-prof" - suffix Utilities = "-utils" - suffix Extra = "" - - prefix Source = "haskell-" - prefix Documentation = "libghc-" - prefix Development = "libghc-" - prefix Profiling = "libghc-" - prefix Utilities = "haskell-" - prefix Extra = "" - -instance Pretty VersionRange where - pretty range = - foldVersionRange' - (text "*") - (\ v -> text "=" <> pretty v) - (\ v -> text ">" <> pretty v) - (\ v -> text "<" <> pretty v) - (\ v -> text ">=" <> pretty v) - (\ v -> text "<=" <> pretty v) - (\ x _ -> text "=" <> pretty x <> text ".*") -- not exactly right - (\ x y -> text "(" <> x <> text " || " <> y <> text ")") - (\ x y -> text "(" <> x <> text " && " <> y <> text ")") - (\ x -> text "(" <> x <> text ")") - range - -instance Pretty Version where - pretty = text . showVersion - -instance Pretty a => Pretty [a] where - pretty xs = text "[" <> hcat (intersperse (text ", ") (map pretty xs)) <> text "]" - -instance (Pretty a, Pretty b) => Pretty (a, b) where - pretty (a, b) = text "(" <> pretty a <> text ", " <> pretty b <> text ")" - -instance Pretty D.BinPkgName where - pretty (D.BinPkgName p) = text "deb:" <> (pretty p) - -instance Pretty D.PkgName where - pretty (D.PkgName p) = text p - -instance Pretty D.Relation where - pretty (D.Rel name ver arch) = - pretty name <> maybe empty pretty ver <> maybe empty pretty arch - -instance Pretty D.VersionReq where - pretty (D.EEQ v) = text "=" <> pretty v - pretty (D.SLT v) = text "<" <> pretty v - pretty (D.LTE v) = text "<=" <> pretty v - pretty (D.GRE v) = text ">=" <> pretty v - pretty (D.SGR v) = text ">" <> pretty v - -instance Pretty D.ArchitectureReq where - pretty (D.ArchOnly ss) = text "[" <> hcat (intersperse (text ",") (map text ss)) <> text "]" - pretty (D.ArchExcept ss) = text "[!" <> hcat (intersperse (text ",") (map text ss)) <> text "]" - -instance Pretty DebianVersion where - pretty = text . show - -instance Show D.Relation where - show = show . pretty -instance Show D.ArchitectureReq where - show = show . pretty - -invertVersionRange :: VersionRange -> VersionRange -invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals - -invertVersionIntervals :: [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] -invertVersionIntervals xs = - case xs of - [] -> [(lb0, NoUpperBound)] - ((LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound, ub) : more) -> - invertVersionIntervals' ub more - ((lb, ub) : more) -> - (lb0, invertLowerBound lb) : invertVersionIntervals' ub more - where - invertVersionIntervals' :: UpperBound -> [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = (invertUpperBound ub0, invertLowerBound lb) : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - lb0 :: LowerBound - lb0 = LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound - -deriving instance Show VersionReq -instance Show DebianVersion where - show = show . prettyDebianVersion - -debianSourcePackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> SrcPkgName -debianSourcePackageName versionSplits name version = SrcPkgName (D.unBinPkgName (debianName Source versionSplits name version)) - -debianDevPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianDevPackageName versionSplits name version = debianName Development versionSplits name version - -debianProfPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianProfPackageName versionSplits name version = debianName Profiling versionSplits name version - -debianDocPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianDocPackageName versionSplits name version = debianName Documentation versionSplits name version - -type DebianBinPackageName = PackageName -> Maybe VersionReq -> BinPkgName - -debianExtraPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianExtraPackageName versionSplits name version = debianName Extra versionSplits name version - -debianUtilsPackageName :: (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianUtilsPackageName versionSplits name version = debianName Utilities versionSplits name version - --- | Return the basename of the debian package for a given version --- relation. If the version split happens at v, this will return the --- ltName is < v and the geName if the relation is >= v. It also handles --- a special case for the name of the haskell-src-exts package. -debianName :: PackageType -> (PackageType -> [VersionSplits]) -> PackageName -> Maybe VersionReq -> BinPkgName -debianName typ versionSplits pname@(PackageName name) version = - case filter (\ x -> pname == packageName x) (versionSplits typ) of - [] -> def - [splits] -> - foldTriples' (\ ltName v geName debName -> - if pname /= packageName splits - then debName - else let split = parseDebianVersion (showVersion v) in - case version of - Nothing -> geName - Just (SLT v') | v' <= split -> ltName - -- Otherwise use ltName only when the split is below v' - Just (EEQ v') | v' < split -> ltName - Just (LTE v') | v' < split -> ltName - Just (GRE v') | v' < split -> ltName - Just (SGR v') | v' < split -> ltName - _ -> geName) - def - splits - _ -> error $ "Multiple splits for cabal package " ++ name - where - foldTriples' :: (BinPkgName -> Version -> BinPkgName -> BinPkgName -> BinPkgName) -> BinPkgName -> VersionSplits -> BinPkgName - foldTriples' = foldTriples - def = mkPkgName (map fixChar name) typ - -fixChar :: Char -> Char -fixChar '_' = '-' -fixChar c = toLower c diff --git a/Distribution/Package/Debian/Interspersed.hs b/Distribution/Package/Debian/Interspersed.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Interspersed.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall -Werror #-} -module Distribution.Package.Debian.Interspersed - ( Interspersed(..) - ) where - -import Debug.Trace - --- | A class of Bs insterspersed with Cs. Minimum implementation is a --- method to return the leftmost B, and another to return the --- following (C,B) pairs. Its unfortunate to require lists in the --- implementation, a fold function would be better (though I find --- implementing such folds to be a pain in the you-know-what.) --- --- The class provides implementations of three folds, each of which --- exposes slightly different views of the data. -class Interspersed t around between | t -> around, t -> between where - leftmost :: t -> around - pairs :: t -> [(between, around)] - - foldTriples :: (around -> between -> around -> r -> r) -> r -> t -> r - foldTriples f r0 x = snd $ foldl (\ (b1, r) (c, b2) -> (b2, f b1 c b2 r)) (leftmost x, r0) (pairs x) - - -- Treat the b's as the centers and the c's as the things to their - -- left and right. Use Maybe to make up for the missing c's at the - -- ends. - foldInverted :: (Maybe between -> around -> Maybe between -> r -> r) -> r -> t -> r - foldInverted f r0 x = - (\ (bn, an, r) -> f bn an Nothing r) $ - foldl g (Nothing, leftmost x, r0) (pairs x) - where - g (b1, a1, r) (b2, a2) = (Just b2, a2, f b1 a1 (Just b2) r) - - foldArounds :: (around -> around -> r -> r) -> r -> t -> r - foldArounds f r0 x = snd $ foldl (\ (a1, r) (_, a2) -> (a2, f a1 a2 r)) (leftmost x, r0) (pairs x) - - foldBetweens :: (between -> r -> r) -> r -> t -> r - foldBetweens f r0 x = foldl (\ r (b, _) -> (f b r)) r0 (pairs x) - --- | An example -data Splits = Splits Double [(String, Double)] deriving Show - -instance Interspersed Splits Double String where - leftmost (Splits x _) = x - pairs (Splits _ x) = x - -_splits :: Splits -_splits = Splits 1.0 [("between 1 and 2", 2.0), ("between 2 and 3", 3.0)] - -_test1 :: () -_test1 = foldTriples (\ l s r () -> trace ("l=" ++ show l ++ " s=" ++ show s ++ " r=" ++ show r) ()) () _splits - -_test2 :: () -_test2 = foldInverted (\ sl f sr () -> trace ("sl=" ++ show sl ++ " f=" ++ show f ++ " sr=" ++ show sr) ()) () _splits diff --git a/Distribution/Package/Debian/Main.hs b/Distribution/Package/Debian/Main.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | --- Module : Distribution.Package.Debian.Main --- Copyright : David Fox 2008 --- --- Maintainer : David Fox --- Stability : alpha --- Portability : portable --- --- Explanation: Main entry point for Debianizer of Cabal packages. - --- 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.Main where - -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Package.Debian (debian) -import Distribution.Package.Debian.Setup (Flags (..), parseArgs) -import Distribution.Simple.Utils (defaultPackageDesc) -import System.Environment (getArgs) - -main :: IO () - -main = do opts <- getArgs >>= parseArgs - let verbosity = rpmVerbosity opts - descPath <- defaultPackageDesc verbosity - pkgDesc <- readPackageDescription verbosity descPath - debian pkgDesc opts diff --git a/Distribution/Package/Debian/Relations.hs b/Distribution/Package/Debian/Relations.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Relations.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, PackageImports, ScopedTypeVariables, - StandaloneDeriving, TupleSections, TypeSynonymInstances #-} -{-# OPTIONS -Wall -fno-warn-orphans #-} - --- | --- 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.Relations - ( allBuildDepends - , buildDependencies - , docDependencies - , cabalDependencies - , versionSplits - ) where - -import Data.Char (isSpace) -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Data.Version (Version(Version)) -import qualified Debian.Relation as D -import Distribution.Simple.Compiler (Compiler(..)) -import Distribution.Package (PackageName(..), Dependency(..)) -import Distribution.PackageDescription (PackageDescription(..), - allBuildInfo, buildTools, pkgconfigDepends, - extraLibs) -import Distribution.Version (anyVersion) -import Distribution.Package.Debian.Setup (Flags(..)) -import Distribution.Package.Debian.Dependencies (PackageType(..), VersionSplits(..), dependencies, mkPkgName) -import System.Exit (ExitCode(ExitSuccess)) -import System.IO.Unsafe (unsafePerformIO) -import System.Process (readProcessWithExitCode) - -cabalDependencies :: Flags -> PackageDescription -> [Dependency] -cabalDependencies flags pkgDesc = catMaybes $ map unboxDependency $ allBuildDepends flags pkgDesc - --- |Debian packages don't have per binary package build dependencies, --- so we just gather them all up here. -allBuildDepends :: Flags -> PackageDescription -> [Dependency_] -allBuildDepends flags pkgDesc = - nub $ map BuildDepends (buildDepends pkgDesc) ++ - concat (map (map BuildTools . buildTools) (allBuildInfo pkgDesc) ++ - map - (map PkgConfigDepends . pkgconfigDepends) - (allBuildInfo pkgDesc) ++ - map (map ExtraLibs . (fixDeps . extraLibs)) (allBuildInfo pkgDesc)) - where - fixDeps :: [String] -> [D.BinPkgName] - fixDeps xs = concatMap (\ cab -> fromMaybe [D.BinPkgName (D.PkgName ("lib" ++ cab ++ "-dev"))] (Map.lookup cab (depMap flags))) xs - --- The build dependencies for a package include the profiling --- libraries and the documentation packages, used for creating cross --- references. -buildDependencies :: Flags -> Compiler -> Dependency_ -> D.Relations -buildDependencies flags compiler (BuildDepends (Dependency name ranges)) = - dependencies flags compiler versionSplits Development (Right name) ranges ++ dependencies flags compiler versionSplits Profiling (Right name) ranges -buildDependencies flags compiler dep@(ExtraLibs _) = - concat (map (\ x -> dependencies flags compiler versionSplits Extra (Left x) anyVersion) $ adapt flags dep) -buildDependencies flags compiler dep = - case unboxDependency dep of - Just (Dependency _name ranges) -> - concat (map (\ x -> dependencies flags compiler versionSplits Extra (Left x) ranges) $ adapt flags dep) - Nothing -> - [] - -adapt :: Flags -> Dependency_ -> [D.BinPkgName] -adapt flags (PkgConfigDepends (Dependency (PackageName pkg) _)) = - maybe (aptFile pkg) (: []) (Map.lookup pkg (execMap flags)) -adapt flags (BuildTools (Dependency (PackageName pkg) _)) = - maybe (aptFile pkg) (: []) (Map.lookup pkg (execMap flags)) -adapt _flags (ExtraLibs x) = [x] -{- - maybe (error ("No mapping from library " ++ x ++ " to debian binary package name")) - (map (\ s -> PackageName ("lib" ++ s ++ "-dev"))) (Map.lookup x (depMap flags)) --} -adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [D.BinPkgName (D.PkgName pkg)] - --- |There are two reasons this may not work, or may work --- incorrectly: (1) the build environment may be a different --- distribution than the parent environment (the environment the --- autobuilder was run from), so the packages in that --- environment might have different names, and (2) the package --- we are looking for may not be installed in the parent --- environment. -aptFile :: String -> [D.BinPkgName] -- Maybe would probably be more correct -aptFile pkg = - unsafePerformIO $ - do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] "" - return $ case ret of - (ExitSuccess, out, _) -> [D.BinPkgName (D.PkgName (takeWhile (not . isSpace) out))] - _ -> [] - --- 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 :: Flags -> Compiler -> Dependency_ -> D.Relations -docDependencies flags compiler (BuildDepends (Dependency name ranges)) = - dependencies flags compiler versionSplits Documentation (Right name) ranges -docDependencies _ _ _ = [] - -data Dependency_ - = BuildDepends Dependency - | BuildTools Dependency - | PkgConfigDepends Dependency - | ExtraLibs D.BinPkgName - deriving (Eq, Show) - -unboxDependency :: Dependency_ -> Maybe Dependency -unboxDependency (BuildDepends d) = Just d -unboxDependency (BuildTools d) = Just d -unboxDependency (PkgConfigDepends d) = Just d -unboxDependency (ExtraLibs _) = Nothing -- Dependency (PackageName d) anyVersion - --- | These are the instances of debian names changing that we know about. -versionSplits :: PackageType -> [VersionSplits] -versionSplits typ = - [ VersionSplits { - packageName = PackageName "parsec" - , oldestPackage = mkPkgName "parsec2" typ - , splits = [(Version [3] [], mkPkgName "parsec3" typ)] } - , VersionSplits { - packageName = PackageName "QuickCheck" - , oldestPackage = mkPkgName "quickcheck1" typ - , splits = [(Version [2] [], mkPkgName "quickcheck2" typ)] } - ] diff --git a/Distribution/Package/Debian/Setup.hs b/Distribution/Package/Debian/Setup.hs deleted file mode 100644 --- a/Distribution/Package/Debian/Setup.hs +++ /dev/null @@ -1,220 +0,0 @@ --- | --- Module : Distribution.Package.Debian.Setup --- Copyright : David Fox 2008 --- --- Maintainer : David Fox --- Stability : alpha --- Portability : portable --- --- Explanation: Command line option processing for building RPM --- packages. - --- 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.Setup ( - Flags(..) - , DebAction(..) - , DebType(..) - , parseArgs - ) where - -import Control.Monad (when) -import Data.Char (toLower, isDigit, ord) -import qualified Data.Map as Map -import Data.Version (Version, parseVersion) -import Debian.Relation (PkgName(..), BinPkgName(..)) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.ReadE (readEOrFail) -import Distribution.PackageDescription (FlagName(..)) -import Distribution.Package (PackageName(..)) -import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) -import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), - usageInfo, getOpt') -import System.Environment (getProgName) -import System.Exit (exitWith, ExitCode (..)) -import System.IO (Handle, hPutStrLn, stderr, stdout) -import Text.ParserCombinators.ReadP (readP_to_S) - -data Flags = Flags - { - rpmPrefix :: FilePath - , rpmCompiler :: CompilerFlavor - , rpmCompilerVersion :: Maybe Version - , rpmConfigurationsFlags :: [(FlagName, Bool)] - , rpmHaddock :: Bool - , rpmHelp :: Bool - , debLibProf :: Bool - , rpmName :: Maybe String - , rpmOptimisation :: Bool - , rpmRelease :: Maybe String - , rpmSplitObjs :: Bool - , debOutputDir :: FilePath - , buildRoot :: FilePath - , rpmVerbosity :: Verbosity - , rpmVersion :: Maybe String - , debMaintainer :: Maybe String - , debAction :: DebAction - , buildDeps :: [String] - , extraDevDeps :: [String] - -- , debName :: Maybe String - , debVersion :: Maybe String - , depMap :: Map.Map String [BinPkgName] - , epochMap :: Map.Map PackageName Int - , revision :: String - , execMap :: Map.Map String BinPkgName - , omitLTDeps :: Bool - , sourceFormat :: String - } - deriving (Eq, Show) - -data DebType = Dev| Prof | Doc deriving (Eq, Read, Show) - -data DebAction = Usage | Debianize | SubstVar DebType | UpdateDebianization deriving (Eq, Show) - -emptyFlags :: Flags - -emptyFlags = Flags - { - rpmPrefix = "/usr/lib/haskell-packages/ghc6" - , rpmCompiler = GHC - , rpmCompilerVersion = Nothing - , rpmConfigurationsFlags = [] - , rpmHaddock = True - , rpmHelp = False - , debLibProf = True - , rpmName = Nothing - , rpmOptimisation = True - , rpmRelease = Nothing - , rpmSplitObjs = True - , debOutputDir = "./debian" - , buildRoot = "/" - , rpmVerbosity = normal - , rpmVersion = Nothing - , debMaintainer = Nothing - , debAction = Usage - , buildDeps = [] - , extraDevDeps = [] - , depMap = Map.empty - , epochMap = Map.empty - -- , debName = Nothing - , debVersion = Nothing - , revision = "-1~hackage1" - , execMap = Map.empty - , omitLTDeps = False - , sourceFormat = "3.0 (native)" - } - -options :: [OptDescr (Flags -> Flags)] - -options = - [ - Option "" ["prefix"] (ReqArg (\ path x -> x { rpmPrefix = path }) "PATH") - "Pass this prefix if we need to configure the package", - Option "" ["ghc"] (NoArg (\x -> x { rpmCompiler = GHC })) - "Compile with GHC", - Option "" ["hugs"] (NoArg (\x -> x { rpmCompiler = Hugs })) - "Compile with Hugs", - Option "" ["jhc"] (NoArg (\x -> x { rpmCompiler = JHC })) - "Compile with JHC", - Option "" ["nhc"] (NoArg (\x -> x { rpmCompiler = NHC })) - "Compile with NHC", - Option "h?" ["help"] (NoArg (\x -> x { rpmHelp = True })) - "Show this help text", - Option "" ["ghc-version"] (ReqArg (\ ver x -> x { rpmCompilerVersion = Just (last (map fst (readP_to_S parseVersion ver)))}) "VERSION") - "Version of GHC in build environment", - Option "" ["name"] (ReqArg (\name x -> x { rpmName = Just name }) "NAME") - "Override the default package name", - Option "" ["disable-haddock"] (NoArg (\x -> x { rpmHaddock = False })) - "Don't generate API docs", - Option "" ["disable-library-profiling"] (NoArg (\x -> x { debLibProf = False })) - "Don't generate profiling libraries", - Option "" ["disable-optimization"] (NoArg (\x -> x { rpmOptimisation = False })) - "Don't generate optimised code", - Option "" ["disable-split-objs"] (NoArg (\x -> x { rpmSplitObjs = False })) - "Don't split object files to save space", - Option "f" ["flags"] (ReqArg (\flags x -> x { rpmConfigurationsFlags = rpmConfigurationsFlags x ++ flagList flags }) "FLAGS") - "Set given flags in Cabal conditionals", - Option "" ["release"] (ReqArg (\rel x -> x { rpmRelease = Just rel }) "RELEASE") - "Override the default package release", - Option "" ["debdir"] (ReqArg (\path x -> x { debOutputDir = path }) "DEBDIR") - ("Override the default output directory (" ++ show (debOutputDir emptyFlags) ++ ")"), - Option "" ["root"] (ReqArg (\ path x -> x { buildRoot = path }) "BUILDROOT") - "Use the compiler information in the given build environment.", - Option "v" ["verbose"] (ReqArg (\verb x -> x { rpmVerbosity = readEOrFail flagToVerbosity verb }) "n") - "Change build verbosity", - Option "" ["version"] (ReqArg (\vers x -> x { rpmVersion = Just vers }) "VERSION") - "Override the default package version", - Option "" ["maintainer"] (ReqArg (\maint x -> x { debMaintainer = Just maint }) "Maintainer Name ") - "Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME", - Option "" ["debianize"] (NoArg (\x -> x {debAction = Debianize})) - "Generate a new debianization, replacing any existing one. One of --debianize, --substvar, or --update-debianization is required.", - Option "" ["build-dep"] (ReqArg (\ name x -> x {buildDeps = name : (buildDeps x)}) "Debian binary package name") - "Specify a package to add to the build dependency list in debian/control, e.g. '--build-dep libglib2.0-dev'.", - Option "" ["dev-dep"] (ReqArg (\ name x -> x {extraDevDeps = name : (extraDevDeps x)}) "Debian binary package name") - "Specify a package to add to the Depends: list of the -dev package, e.g. '--build-dep libssl-dev'.", - Option "" ["map-dep"] (ReqArg (\ pair x -> x {depMap = case break (== '=') pair of - (cab, (_ : deb)) -> Map.insertWith (++) cab [BinPkgName (PkgName deb)] (depMap x) - (_, "") -> error "usage: --dep-map CABALNAME=DEBIANNAME"}) "CABALNAME=DEBIANNAME") - "Specify a mapping from the name appearing in the Extra-Library field of the cabal file to a debian binary package name, e.g. --dep-map cryptopp=libcrypto-dev", - -- Option "" ["deb-name"] (ReqArg (\ name x -> x {debName = Just name}) "NAME") - -- "Specify the base name of the debian package, the part between 'libghc-' and '-dev'. Normally this is the downcased cabal name.", - Option "" ["deb-version"] (ReqArg (\ version x -> x {debVersion = Just version}) "VERSION") - "Specify the version number for the debian package. This will pin the version and should be considered dangerous.", - Option "" ["revision"] (ReqArg (\ rev x -> x {revision = rev}) "REVISION") - "Add this string to the cabal version to get the debian version number. By default this is '-1~hackage1'. Debian policy says this must either be empty (--revision '') or begin with a dash.", - Option "" ["epoch-map"] (ReqArg (\ pair x -> x {epochMap = - case break (== '=') pair of - (_, (_ : ['0'])) -> epochMap x - (cab, (_ : [d])) | isDigit d -> Map.insert (PackageName cab) (ord d - ord '0') (epochMap x) - _ -> error "usage: --epoch-map CABALNAME=DIGIT"}) "CABALNAME=DIGIT") - "Specify a mapping from the cabal package name to a digit to use as the debian package epoch number, e.g. --epoch-map HTTP=1", - Option "" ["substvar"] (ReqArg (\ name x -> x {debAction = SubstVar (read name)}) "Doc, Prof, or Dev") - (unlines ["Write out the list of dependencies required for the dev, prof or doc package depending", - "on the argument. This value can be added to the appropriate substvars file."]), - Option "" ["update-debianization"] (NoArg (\x -> x {debAction = UpdateDebianization})) - "Update an existing debianization, or generate a new one.", - Option "" ["exec-map"] (ReqArg (\ s x -> x {execMap = case break (== '=') s of - (cab, (_ : deb)) -> Map.insert cab (BinPkgName (PkgName deb)) (execMap x) - _ -> error "usage: --exec-map CABALNAME=DEBNAME"}) "EXECNAME=DEBIANNAME") - "Specify a mapping from the name appearing in the Build-Tool field of the cabal file to a debian binary package name, e.g. --exec-map trhsx=haskell-hsx-utils", - Option "" ["omit-lt-deps"] (NoArg (\x -> x { omitLTDeps = True })) - "Don't generate the << dependency when we see a cabal equals dependency.", - Option "" ["quilt"] (NoArg (\ x -> x {sourceFormat = "3.0 (quilt)"})) - "The package has an upstream tarball, write '3.0 (quilt)' into source/format." - ] - --- Lifted from Distribution.Simple.Setup, since it's not exported. -flagList :: String -> [(FlagName, Bool)] -flagList = map tagWithValue . words - where tagWithValue ('-':name) = (FlagName (map toLower name), False) - tagWithValue name = (FlagName (map toLower name), True) - -printHelp :: Handle -> IO () - -printHelp h = do - progName <- getProgName - let info = "Usage: " ++ progName ++ " [FLAGS]\n" - hPutStrLn h (usageInfo info options) - -parseArgs :: [String] -> IO Flags - -parseArgs args = do - let (os, args', unknown, errs) = getOpt' RequireOrder options args - opts = foldl (flip ($)) emptyFlags os - when (rpmHelp opts || debAction opts == Usage) $ do - printHelp stdout - exitWith ExitSuccess - when (not (null errs)) $ do - hPutStrLn stderr "Errors:" - mapM_ (hPutStrLn stderr) errs - exitWith (ExitFailure 1) - when (not (null unknown)) $ do - hPutStrLn stderr "Unrecognised options:" - mapM_ (hPutStrLn stderr) unknown - exitWith (ExitFailure 1) - when (not (null args')) $ do - hPutStrLn stderr "Unrecognised arguments:" - mapM_ (hPutStrLn stderr) args' - exitWith (ExitFailure 1) - return opts diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,22 @@ #!/usr/bin/runhaskell import Distribution.Simple +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) import Distribution.Simple.Program +import System.Cmd +import System.Exit -main = defaultMainWithHooks simpleUserHooks +main = defaultMainWithHooks simpleUserHooks { + postBuild = + \ _ _ _ lbi -> + case buildDir lbi of + "dist-ghc/build" -> return () + _ -> runTestScript lbi + , runTests = \ _ _ _ lbi -> runTestScript lbi + } + +runTestScript lbi = + system (buildDir lbi ++ "/cabal-debian-tests/cabal-debian-tests") >>= \ code -> + if code == ExitSuccess then return () else error "unit test failure" + + diff --git a/cabal-debian.cabal b/cabal-debian.cabal --- a/cabal-debian.cabal +++ b/cabal-debian.cabal @@ -1,5 +1,5 @@ Name: cabal-debian -Version: 1.25 +Version: 3.0.3 License: BSD3 License-File: debian/copyright Author: David Fox @@ -8,42 +8,85 @@ Homepage: http://src.seereason.com/cabal-debian Build-Type: Simple Synopsis: Create a debianization for a cabal package -Cabal-Version: >= 1.6 -Description: - A program which creates a debian subdirectory containing the required - files to build a deb. -Data-Files: - debian/cabal-debian.1, - debian/cabal-debian.manpages, +Cabal-Version: >= 1.8 +Extra-Source-Files: debian/changelog, - debian/compat, - debian/control, - debian/copyright, - debian/rules + debian/Debianize.hs +Description: + Tool for creating debianizations of Haskell packages based on the .cabal + file. If apt-file is installed it will use it to discover what is the + debian package name of a C library. Source-Repository head type: darcs - location: http://src.seereason.com/cabal-debian + location: http://src.seereason.com/debian-tools -Flag cabal19 - Description: True if Cabal >= 1.9 is available +Library + Hs-Source-Dirs: src + GHC-Options: -threaded -Wall -O2 + Build-Depends: + ansi-wl-pprint, + applicative-extras, + base < 5, + bytestring, + Cabal >= 1.9, + containers, + data-lens, + debian >= 3.70, + Diff, + directory, + filepath, + hsemail, + HUnit, + mtl, + network, + parsec >= 3, + process, + pureMD5, + regex-tdfa, + syb, + text, + unix, + Unixutils >= 1.50, + utf8-string + Exposed-Modules: + Data.Algorithm.Diff.Context + Data.Algorithm.Diff.Pretty + Debian.Debianize + Debian.Debianize.Atoms + Debian.Debianize.Bundled + Debian.Debianize.ControlFile + Debian.Debianize.Debianize + Debian.Debianize.Dependencies + Debian.Debianize.Files + Debian.Debianize.Finalize + Debian.Debianize.Generic + Debian.Debianize.Goodies + Debian.Debianize.Interspersed + Debian.Debianize.Input + Debian.Debianize.Options + Debian.Debianize.SubstVars + Debian.Debianize.Tests + Debian.Debianize.Types + Debian.Debianize.Utility + Debian.Orphans + Debian.Policy + Distribution.Version.Invert + Triplets Executable cabal-debian - Main-is: CabalDebian.hs - ghc-options: -threaded -W - Build-Depends: base < 5, bytestring, Cabal >= 1.6.0.1, containers, debian >= 3.63, directory, filepath, mtl, parsec >= 3, pretty, process, regex-tdfa, unix, Unixutils >= 1.50, utf8-string - Extensions: ExistentialQuantification CPP - if flag(cabal19) - build-depends: Cabal >= 1.9 - cpp-options: -DCABAL19 - else - build-depends: Cabal >= 1.8 - cpp-options: -DCABAL18 - Other-Modules: - Distribution.Package.Debian, - Distribution.Package.Debian.Bundled, - Distribution.Package.Debian.Dependencies, - Distribution.Package.Debian.Interspersed, - Distribution.Package.Debian.Main, - Distribution.Package.Debian.Relations, - Distribution.Package.Debian.Setup + Main-is: src/CabalDebian.hs + ghc-options: -threaded -Wall -O2 + Build-Depends: + base, + cabal-debian, + containers + +Executable cabal-debian-tests + Main-Is: src/Tests.hs + GHC-Options: -Wall -O2 -threaded -rtsopts + Build-Depends: + base, + cabal-debian, + Diff, + HUnit diff --git a/debian/Debianize.hs b/debian/Debianize.hs new file mode 100644 --- /dev/null +++ b/debian/Debianize.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +import Debian.Debianize +import Data.Lens.Lazy +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT)) +import Debian.Version (parseDebianVersion) +import Data.Map as Map (insertWith) +import Data.Maybe (fromMaybe) +import Data.Set as Set (insert, union, singleton) +import Data.Text as Text (intercalate) + +main :: IO () +main = + do new <- debianization "." + (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) $ + setL changelog (Just log) $ + setL compat (Just 7) $ + setL standards (Just (StandardsVersion 3 9 3 Nothing)) $ + setL sourceFormat (Just Native3) $ + setL utilsPackageName (Just (BinPkgName "cabal-debian")) $ + modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") Nothing Nothing))) $ + modL conflicts (Map.insertWith union (BinPkgName "cabal-debian") + (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) $ + modL description (Map.insertWith (error "test7") (BinPkgName "cabal-debian") + (Text.intercalate "\n" + [ "Create a debianization for a cabal package" + , " Tool for creating debianizations of Haskell packages based on the .cabal" + , " file. If apt-file is installed it will use it to discover what is the" + , " debian package name of a C library." + , " ." + , " Author: David Fox " + , " Upstream-Maintainer: David Fox " ])) $ + defaultAtoms) + inputDebianization "." defaultAtoms >>= \ old -> case compareDebianization old (copyFirstLogEntry old new) of + "" -> return () + s -> error $ "Debianization mismatch:\n" ++ s + -- This would overwrite the existing debianization rather than + -- just make sure it matches: + -- writeDebianization "." new + +-- | This copies the first log entry of deb1 into deb2. Because the +-- debianization process updates that log entry, we need to undo that +-- update in order to get a clean comparison. +copyFirstLogEntry :: Atoms -> Atoms -> Atoms +copyFirstLogEntry deb1 deb2 = + modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2 + where + ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1) + ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2) diff --git a/debian/cabal-debian.1 b/debian/cabal-debian.1 deleted file mode 100644 --- a/debian/cabal-debian.1 +++ /dev/null @@ -1,120 +0,0 @@ -.\"Original page generated by txt2man and then hacked extensively. -.TH CABAL-DEBIAN 1 "May 10, 2010" - -.SH NAME -cabal-debian \- create Debian package meta data from a Haskell cabal file. - -.SH SYNOPSIS -.B cabal-debian -.RI [flags] - -.SH DESCRIPTION -cabal-debian will generated the Debian meta data for a Debian package from the -cabal file of a Haskell package. The program expects to find the package's -.cabal file in the directory from which it was run. - -.TP -.B -\fB--prefix=PATH\fP -Pass this prefix if we need to configure the package - -.TP -.B -\fB--ghc\fP -Compile with GHC. - -.TP -.B -\fB--hugs\fP -Compile with HUGS. - -.TP -.B -\fB--jhc\fP -Compile with JHC. - -.TP -.B -\fB--nhc\fP -Compile with NHC. - -.TP -.B -\fB-h, -?, \-\-help\fP -Show this help text. - -.TP -.B -\fB--name\fP=NAME -Override the default package name. -.TP -.B -\fB--disable-haddock\fP -Don't generate API docs. -.TP -.B -\fB--disable-library-profiling\fP -Don't generate profiling libraries. -.TP -.B -\fB--disable-optimization\fP -Don't generate optimised code. - -.TP -.B -\fB--disable-split-objs\fP -Don't split object files to save space. - -.TP -.B -\fB-f\fP FLAGS, \fB--flags\fP=FLAGS -Set given flags in Cabal conditionals. - -.TP -.B -\fB--release\fP=RELEASE -Override the default package release. - -.TP -.B -\fB--debdir\fP=DEBDIR -Override the default output directory ("./debian"). - -.TP -.B -\fB-v n,q \fB--verbose=n\fP -Change build verbosity. - -.TP -.B -\fB--version\fP=VERSION -Override the default package version. - -.TP -.B -\fB--maintainer\fP=Maintainer Name -Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME. - -.TP -.B -\fB--debianize\fP -Generate a new debianization, replacing any existing one. One of -\fB--debianize\fP, \fB--substvar\fP, or \fB--update-debianization\fP is -required. - -.TP -.B -\fB--substvar\fP=Doc, Prof, or Dev -Write out the list of dependencies required for the dev, prof or doc package -depending on the argument. This value can be added to the appropriate substvars -file. - -.TP -.B -\fB--update-debianization\fP -Update an existing debianization. - -.SH AUTHOR -This manual page was originally written by Erik de Castro Lopo - for the Debian GNU/Linux system (but may be used by -others). diff --git a/debian/cabal-debian.manpages b/debian/cabal-debian.manpages deleted file mode 100644 --- a/debian/cabal-debian.manpages +++ /dev/null @@ -1,1 +0,0 @@ -debian/*.1 diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,281 @@ +haskell-cabal-debian (3.0.3) unstable; urgency=low + + * Due to a typo, the noDocumentationLibrary lens was turning off + profiling rather than documentation. + + -- David Fox Fri, 08 Feb 2013 17:14:09 -0800 + +haskell-cabal-debian (3.0.2) unstable; urgency=low + + * Fix argument and exception handling in cabal-debian + * Make Standards-Version field non-mandatory + * Make sure every binary deb paragraph has a non-empty description + + -- David Fox Thu, 07 Feb 2013 10:03:25 -0800 + +haskell-cabal-debian (3.0.1) unstable; urgency=low + + * Don't build Debian version numbers with revision (Just ""). + * Output the descriptions of the binary packages. + + -- David Fox Tue, 05 Feb 2013 14:48:33 -0800 + +haskell-cabal-debian (3.0) unstable; urgency=low + + * Moved the Distribution.Debian modules to Debian.Cabal and + Debian.Debianize. + * Refactored the debianize function for easier testing + * Added test cases. + * Add a Debianization type that intends to fully describe a debian + package, with functions to read, build, modify, and write a + Debianization. + + -- David Fox Wed, 26 Dec 2012 05:45:35 -0800 + +haskell-cabal-debian (2.6.3) unstable; urgency=low + + * Fix pretty printing of Relations (i.e. dependency lists.) There + is an instance for printing lists in ansi-wl-pprint which prevents + us from writing customized Pretty instances for type aliases like + Relations, AndRelation, and OrRelation. + + -- David Fox Fri, 04 Jan 2013 09:30:48 -0800 + +haskell-cabal-debian (2.6.2) unstable; urgency=low + + * Fix a bug constructing the destination pathnames that was dropping + files that were supposed to be installed into packages. + + -- David Fox Thu, 20 Dec 2012 06:49:25 -0800 + +haskell-cabal-debian (2.6.1) unstable; urgency=low + + * Remove the modifyAtoms field from the Flags record, we want to + be able to create instances like Read and Show for this type. + The modifyAtoms function is now passed separately to debianize. + * The flags field of Server was renamed serverFlags because the + newly exported Config record has a flags field. + + -- David Fox Wed, 19 Dec 2012 09:45:22 -0800 + +haskell-cabal-debian (2.5.10) unstable; urgency=low + + * Filter cabal self dependencies out before generating + Build-Depends-Indep, just as we added code to filter them out + of Build-Depends in version 2.5.7. + + -- David Fox Tue, 18 Dec 2012 13:23:39 -0800 + +haskell-cabal-debian (2.5.9) unstable; urgency=low + + * Always add +RTS -IO -RTS to server flags. + + -- David Fox Sun, 16 Dec 2012 10:40:52 -0800 + +haskell-cabal-debian (2.5.8) unstable; urgency=low + + * Add a builtin list for ghc-7.6.1. + + -- David Fox Sat, 15 Dec 2012 07:04:49 -0800 + +haskell-cabal-debian (2.5.7) unstable; urgency=low + + * Filter out cabal self-dependencies before building the debian + dependencies. In cabal a self dependency means you need the library + to build an executable, while in debian it means you need an older + version installed to build the current version. + + -- David Fox Thu, 29 Nov 2012 08:42:30 -0800 + +haskell-cabal-debian (2.5.6) unstable; urgency=low + + * Don't add --base-uri and --http-port arguments automatically, they can be + computed by calling the oldClckwrksFlags function and adding the value to + the flags field. Clckwrks-0.3 no longer needs the --base-uri argument. + + -- David Fox Tue, 27 Nov 2012 13:34:31 -0800 + +haskell-cabal-debian (2.5.5) unstable; urgency=low + + * Have the debianize function return False if there is no debian/Debianize.hs file, + but throw an exception if running it failed, so we notice bad debianization code. + + -- David Fox Tue, 27 Nov 2012 07:34:51 -0800 + +haskell-cabal-debian (2.5.4) unstable; urgency=low + + * Insert "SetEnv proxy-sendcl 1" line into Apache config. + + -- David Fox Tue, 20 Nov 2012 13:43:54 -0800 + +haskell-cabal-debian (2.5.3) unstable; urgency=low + + * Remove extra copy of binary from the executable debs + * Add a sourcePackageName field to Flags, and a --source-package-name + command line option. + + -- David Fox Sat, 17 Nov 2012 00:16:21 -0800 + +haskell-cabal-debian (2.5.2) unstable; urgency=low + + * Fix the path to where the DHInstallTo and DHInstallCabalExecTo + DebAtoms put their files. + + -- David Fox Fri, 16 Nov 2012 18:11:45 -0800 + +haskell-cabal-debian (2.5.1) unstable; urgency=low + + * Add a destName field to Executable so we can give installed + executables a different name than they had in the build. + + -- David Fox Fri, 16 Nov 2012 15:37:16 -0800 + +haskell-cabal-debian (2.5) unstable; urgency=low + + * Add a debName field to the Executable record, before the deb + package name had to equal the executable name. + + -- David Fox Fri, 16 Nov 2012 12:32:39 -0800 + +haskell-cabal-debian (2.4.2) unstable; urgency=low + + * Move location of cabal install files from dist/build/install to + debian/cabalInstall, the dist directory was getting wiped at bad + moments. + * Split the autobuilder function autobuilderDebianize into two + new functions in cabal-debian: runDebianize and callDebianize. + * Custom debianization code now goes in debian/Debianize.hs rather than + in setup, so we can distinguish it failing from it not existing more + easily. + + -- David Fox Thu, 15 Nov 2012 11:00:08 -0800 + +haskell-cabal-debian (2.4.1) unstable; urgency=low + + * We need to verify that debian/compat was created after running the + debianize function, because ghc still exits with ExitSuccess + + -- David Fox Thu, 15 Nov 2012 06:34:02 -0800 + +haskell-cabal-debian (2.4.0) unstable; urgency=low + + * You can run a function in Setup.hs other than main using ghc -e, so we + will use this trick to run the debianize function directly rather than + running main. + * Eliminate the autobuilderDebianize function. + + -- David Fox Thu, 15 Nov 2012 04:05:49 -0800 + +haskell-cabal-debian (2.3.4) unstable; urgency=low + + * Fix the builddir used when running the cabal-debian standalone + executable - it was dist-cabal/build, so the resulting debianization + had files in places where cabal didn't expect them. + + -- David Fox Tue, 13 Nov 2012 06:20:51 -0800 + +haskell-cabal-debian (2.3.3) unstable; urgency=low + + * Eliminate class MonadBuild and the BuildT monad. + + -- David Fox Sun, 11 Nov 2012 17:46:31 -0800 + +haskell-cabal-debian (2.3.2) unstable; urgency=low + + * Fix exception that was keeping changelogs from being preserved. + + -- David Fox Sat, 10 Nov 2012 10:07:50 -0800 + +haskell-cabal-debian (2.3.1) unstable; urgency=low + + * Fix the extension of the debhelper links files + * Add a general mechanism for installing a file into a deb when + we have the file's text in a String (rather than in a file.) + + -- David Fox Sat, 10 Nov 2012 07:35:09 -0800 + +haskell-cabal-debian (2.3) unstable; urgency=low + + * Add MonadBuild. + + -- David Fox Fri, 09 Nov 2012 12:21:14 -0800 + +haskell-cabal-debian (2.2.1) unstable; urgency=low + + * Add a modifyAtoms function to Flags that is applied to final list of + DebAtom before writing the debianization. + * Add DHApacheSite and DHInstallCabalExec atoms so atoms don't depend on + the build directory + * Add #DEBHELPER# and exit 0 to default web server postinst. + + -- David Fox Fri, 09 Nov 2012 10:25:32 -0800 + +haskell-cabal-debian (2.2.0) unstable; urgency=low + + * Append a trailing slash to the --base-uri argument passed to the + server. This is required by Web.Routes.Site.runSite. + + -- David Fox Thu, 08 Nov 2012 04:40:08 -0800 + +haskell-cabal-debian (2.1.4) unstable; urgency=low + + * Merge the Executable and Script constructors of the Executable type + * Add a destDir field to Executable to specify the destination. + + -- David Fox Tue, 06 Nov 2012 13:24:25 -0800 + +haskell-cabal-debian (2.1.3) unstable; urgency=low + + * Don't append a slash to the base-uri. + * Construct the name of the data directory in /usr/share from the cabal + package name rather than the debian source package name. + * Add a --self-depend flag to include a build dependency on this library + in all generated debianizations. + + -- David Fox Tue, 06 Nov 2012 07:07:57 -0800 + +haskell-cabal-debian (2.1.2) unstable; urgency=low + + * Output the server support files. + + -- David Fox Tue, 06 Nov 2012 06:37:18 -0800 + +haskell-cabal-debian (2.1.1) unstable; urgency=low + + * Restore code that checks for version number match when validating + a debianization. The autobuilder can now pass the version number + to cabal-debian, so it should match. + + -- David Fox Mon, 05 Nov 2012 17:42:32 -0800 + +haskell-cabal-debian (2.1.0) unstable; urgency=low + + * Enable processing of Script, Server and WebSite executables. + + -- David Fox Mon, 05 Nov 2012 12:45:42 -0800 + +haskell-cabal-debian (2.0.9) unstable; urgency=low + + * Add a Library section, export all the modules. + + -- David Fox Mon, 05 Nov 2012 06:41:25 -0800 + +haskell-cabal-debian (2.0.8) unstable; urgency=low + + * Bypass abandoned versions. + + -- David Fox Sat, 03 Nov 2012 06:13:27 -0700 + +haskell-cabal-debian (1.26) unstable; urgency=low + + * Don't try to update the existing debianization, except for the + changelog where we retain entries that look older than the one + we generate. + * Use .install files instead of adding rules to debian/rules + * Add --depends and --conflicts options + + -- David Fox Thu, 25 Oct 2012 12:03:49 -0700 + haskell-cabal-debian (1.25) unstable; urgency=low * If the --disable-haddock flag is given omit the doc package from the diff --git a/debian/compat b/debian/compat deleted file mode 100644 --- a/debian/compat +++ /dev/null @@ -1,1 +0,0 @@ -7 diff --git a/debian/control b/debian/control deleted file mode 100644 --- a/debian/control +++ /dev/null @@ -1,40 +0,0 @@ -Source: haskell-cabal-debian -Priority: extra -Section: haskell -Maintainer: David Fox -Build-Depends: debhelper (>= 7.0), - haskell-devscripts (>= 0.8), - cdbs, - ghc, - ghc-prof, - libghc-unixutils-dev (>= 1.50), - libghc-unixutils-prof (>= 1.50), - libghc-debian-dev (>= 3.63), - libghc-debian-prof (>= 3.63), - libghc-mtl-dev, - libghc-mtl-prof, - libghc-parsec3-dev (>= 3), - libghc-parsec3-prof (>= 3), - libghc-regex-tdfa-dev, - libghc-regex-tdfa-prof, - libghc-utf8-string-dev, - libghc-utf8-string-prof -Build-Depends-Indep: ghc-doc, - libghc-unixutils-doc (>= 1.50), - libghc-debian-doc (>= 3.63), - libghc-mtl-doc, - libghc-parsec3-doc (>= 3), - libghc-regex-tdfa-doc, - libghc-utf8-string-doc -Standards-Version: 3.9.1 -Homepage: http://src.seereason.com/cabal-debian - -Package: cabal-debian -Architecture: any -Section: misc -Depends: ${shlibs:Depends}, ${haskell:Depends}, ${misc:Depends}, apt-file -Conflicts: haskell-debian-utils (<< 3.59) -Description: Create a debianization for a cabal package - Tool for creating debianizations of Haskell packages based on the .cabal - file. If apt-file is installed it will use it to discover what is the - debian package name of a C library. diff --git a/debian/rules b/debian/rules deleted file mode 100644 --- a/debian/rules +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/make -f - -DEB_CABAL_PACKAGE = cabal-debian - -include /usr/share/cdbs/1/rules/debhelper.mk -include /usr/share/cdbs/1/class/hlibrary.mk - -build/cabal-debian:: build-ghc-stamp -binary-fixup/cabal-debian:: - install -m 755 -s -D dist-ghc/build/cabal-debian/cabal-debian debian/cabal-debian/usr/bin/cabal-debian || true - -# How to install an extra file into the documentation package -#binary-fixup/libghc-cabal-debian-doc:: -# echo "Some informative text" > debian/libghc-cabal-debian-doc/usr/share/doc/libghc-cabal-debian-doc/AnExtraDocFile diff --git a/src/CabalDebian.hs b/src/CabalDebian.hs new file mode 100644 --- /dev/null +++ b/src/CabalDebian.hs @@ -0,0 +1,11 @@ +-- | This is the main function of the cabal-debian executable. This +-- is generally run by the autobuilder to debianize packages that +-- don't have any custom debianization code in Setup.hs. This is a +-- less flexible and powerful method than calling the debianize +-- function directly, many sophisticated configuration options cannot +-- be accessed using the command line interface. + +import Debian.Debianize.Debianize (cabalDebian) + +main :: IO () +main = cabalDebian diff --git a/src/Data/Algorithm/Diff/Context.hs b/src/Data/Algorithm/Diff/Context.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithm/Diff/Context.hs @@ -0,0 +1,54 @@ +module Data.Algorithm.Diff.Context + ( contextDiff + , groups + ) where + +import Data.Algorithm.Diff (Diff(..), getGroupedDiff) + +-- | Do a grouped diff and then turn it into a list of hunks, where +-- each hunk is a grouped diff with at most N elements of common +-- context around each one. +contextDiff :: Eq a => Int -> [a] -> [a] -> [[Diff [a]]] +contextDiff context a b = + group $ swap $ trimTail $ trimHead $ concatMap split $ getGroupedDiff a b + where + -- Split common runs longer than 2N elements, keeping first and + -- last N lines. + split (Both xs ys) = + case length xs of + n | n > (2 * context) -> [Both (take context xs) (take context ys), Both (drop (n - context) xs) (drop (n - context) ys)] + _ -> [Both xs ys] + split x = [x] + -- If split created a a pair of Both's at the beginning or end + -- of the diff, remove the outermost. + trimHead [] = [] + trimHead [Both _ _] = [] + trimHead [Both _ _, Both _ _] = [] + trimHead (Both _ _ : x@(Both _ _) : more) = x : more + trimHead xs = trimTail xs + trimTail [x@(Both _ _), Both _ _] = [x] + trimTail (x : more) = x : trimTail more + trimTail [] = [] + -- If we see Second before First swap them so that the deletions + -- appear before the additions. + swap (x@(Second _) : y@(First _) : xs) = y : x : swap xs + swap (x : xs) = x : swap xs + swap [] = [] + -- Split the list wherever we see adjacent Both constructors + group xs = + groups (\ x y -> not (isBoth x && isBoth y)) xs + where + isBoth (Both _ _) = True + isBoth _ = False + +-- | Group the elements whose adjacent pairs satisfy the predicate. +-- Differs from groupBy because the predicate does not have to define +-- a total ordering. +groups :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] +groups f xs = + filter (/= []) $ reverse (groups' [[]] xs) + where + groups' (r : rs) (x : y : xs') | f x y = groups' ((x : r) : rs) (y : xs') + groups' (r : rs) (x : y : xs') = groups' ([y] : reverse (x : r) : rs) xs' + groups' (r : rs) [y] = reverse (y : r) : rs + groups' rs [] = rs diff --git a/src/Data/Algorithm/Diff/Pretty.hs b/src/Data/Algorithm/Diff/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Algorithm/Diff/Pretty.hs @@ -0,0 +1,17 @@ +module Data.Algorithm.Diff.Pretty + ( prettyDiff + ) where + +import Data.Algorithm.Diff (Diff(..)) +import Data.Monoid (mconcat, (<>)) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), Doc, text, empty) + +prettyDiff :: (Pretty a, Pretty b, Pretty c) => a -> b -> [[Diff [c]]] -> Doc +prettyDiff _ _ [] = empty +prettyDiff old new hunks = + text "--- " <> pretty old <> text "\n+++ " <> pretty new <> text "\n" <> mconcat (map (\ hunk -> text "@@\n" <> p hunk) hunks) + where + p (Both ts _ : more) = mconcat (map (\ l -> text " " <> pretty l <> text "\n") ts) <> p more + p (First ts : more) = mconcat (map (\ l -> text "-" <> pretty l <> text "\n") ts) <> p more + p (Second ts : more) = mconcat (map (\ l -> text "+" <> pretty l <> text "\n") ts) <> p more + p [] = empty diff --git a/src/Debian/Debianize.hs b/src/Debian/Debianize.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize.hs @@ -0,0 +1,73 @@ +-- | QUICK START: You can either run the cabal-debian executable, or +-- for more power and flexibility you can construct a +-- 'Debian.Debianize.Atoms' value and pass it to the +-- 'Debian.Debianize.debianize' function. The +-- 'Debian.Debianize.callDebianize' function retrieves extra arguments +-- from the @CABALDEBIAN@ environment variable and calls +-- 'Debian.Debianize.debianize' with the build directory set as it +-- would be when the packages is built by @dpkg-buildpackage@. +-- +-- To see what your debianization would produce, or how it differs +-- from the debianization already present: +-- +-- > % cabal-debian --debianize -n +-- +-- This is equivalent to the library call +-- +-- > % ghc -e 'Debian.Debianize.callDebianize ["-n"]' +-- +-- To actually create the debianization and then build the debs, +-- +-- > % ghc -e 'Debian.Debianize.callDebianize []' +-- > % sudo dpkg-buildpackage +-- +-- At this point you may need to modify Cabal.defaultFlags to achieve +-- specific packaging goals. Create a module for this in debian/Debianize.hs: +-- +-- > import Distribution.Debian (Flags(..), defaultFlags) +-- > main = debianize (defaultFlags { extraDevDeps = "haskell-hsx-utils" : extraDevDeps defaultFlags}) +-- +-- Then to test it, +-- +-- > % CABALDEBIAN='["-n"]' runhaskell debian/Debianize.hs +-- +-- and to run it +-- +-- > % runhaskell debian/Debianize.hs +module Debian.Debianize + ( module Debian.Debianize.Atoms + , module Debian.Debianize.Bundled + , module Debian.Debianize.ControlFile + , module Debian.Debianize.Debianize + , module Debian.Debianize.Dependencies + , module Debian.Debianize.Files + , module Debian.Debianize.Finalize + , module Debian.Debianize.Generic + , module Debian.Debianize.Goodies + , module Debian.Debianize.Input + , module Debian.Debianize.Interspersed + , module Debian.Debianize.Options + , module Debian.Debianize.SubstVars + , module Debian.Debianize.Tests + , module Debian.Debianize.Types + , module Debian.Debianize.Utility + , module Debian.Policy + ) where + +import Debian.Debianize.Atoms +import Debian.Debianize.Bundled +import Debian.Debianize.Debianize +import Debian.Debianize.Dependencies +import Debian.Debianize.Files +import Debian.Debianize.Finalize +import Debian.Debianize.Generic +import Debian.Debianize.Goodies +import Debian.Debianize.Input +import Debian.Debianize.Interspersed +import Debian.Debianize.Options +import Debian.Debianize.SubstVars +import Debian.Debianize.Tests +import Debian.Debianize.Types +import Debian.Debianize.ControlFile hiding (depends, conflicts, maintainer, description, section) +import Debian.Debianize.Utility +import Debian.Policy diff --git a/src/Debian/Debianize/Atoms.hs b/src/Debian/Debianize/Atoms.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Atoms.hs @@ -0,0 +1,1207 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections #-} +module Debian.Debianize.Atoms + ( Atoms + -- * Modes of operation + , verbosity + , dryRun + , validate + , debAction + , flags + , warning + -- * Cabal info + , compilerVersion + , packageDescription + , buildDir + , dataDir + , compiler + , extraLibMap + , execMap + , cabalFlagAssignments + -- * Global debian info + , versionSplits + , epochMap + -- * High level information about the debianization + , description + , executable + , serverInfo + , website + , backups + , apacheSite + , missingDependencies + , utilsPackageName + , sourcePackageName + , revision + , debVersion + , maintainer + , packageInfo + , omitLTDeps + , noProfilingLibrary + , noDocumentationLibrary + , copyright + , sourceArchitecture + , binaryArchitectures + , sourcePriority + , binaryPriorities + , sourceSection + , binarySections + , buildDeps + , buildDepsIndep + , depends + , conflicts + , extraDevDeps + -- * Debianization files and file fragments + , rulesHead + , rulesFragments + , postInst + , postRm + , preInst + , preRm + , compat + , sourceFormat + , watch + , changelog + , comments + , control + , standards + , logrotateStanza + , link + , install + , installTo + , installData + , file + , installCabalExec + , installCabalExecTo + , installDir + , installInit + , intermediateFiles + ) where + +import Data.Generics (Data, Typeable) +import Data.Lens.Lazy (Lens, lens, getL, modL) +import Data.Map as Map (Map, fold, foldWithKey, insertWith, empty, insert) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.Set as Set (Set, maxView, empty, union, singleton, fold, insert) +import Data.Text (Text) +import Data.Version (Version, showVersion) +import Debian.Changes (ChangeLog) +import Debian.Debianize.ControlFile (SourceDebDescription(standardsVersion), newSourceDebDescription) +import Debian.Debianize.Types (PackageInfo(..), Site(..), Server(..), InstallFile(..), VersionSplits(..), DebAction(..)) +import Debian.Orphans () +import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion) +import Debian.Relation (SrcPkgName, BinPkgName, Relation(..)) +import Debian.Version (DebianVersion) +import Distribution.License (License) +import Distribution.Package (PackageName(PackageName), PackageIdentifier(..)) +import Distribution.PackageDescription as Cabal (PackageDescription(package), FlagName, PackageDescription) +import Distribution.Simple.Compiler (Compiler) +import Prelude hiding (init, unlines, log) +import System.FilePath (()) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) + +-- All the internals of this module is a steaming pile of poo, except +-- for the stuff that is exported. + +data DebAtomKey + = Source + | Binary BinPkgName + deriving (Eq, Ord, Data, Typeable, Show) + +-- | The smallest pieces of debhelper information. Some of these are +-- converted directly into files in the debian directory, others +-- become fragments of those files, and others are first converted +-- into different DebAtom values as new information becomes available. +data DebAtom + = NoDocumentationLibrary + -- ^ Do not produce a libghc-foo-doc package. + | NoProfilingLibrary + -- ^ Do not produce a libghc-foo-prof package. + | CompilerVersion Version + -- ^ Specify the version number of the GHC compiler in the build + -- environment. The default is to assume that version is the same + -- as the one in the environment where cabal-debian is running. + -- This is used to look up hard coded lists of packages bundled + -- with the compiler and their version numbers. (This could + -- certainly be done in a more beautiful way.) + | DHPackageDescription PackageDescription + -- ^ The cabal package description record + | DHCompiler Compiler + -- ^ The Compiler value returned with the Cabal + -- PackageDescription, then used to determine what libraries + -- (i.e. dependencies) are provided by the compiler. + | BuildDir FilePath + -- ^ The build directory used by cabal, typically dist/build when + -- building manually or dist-ghc/build when building using GHC and + -- haskell-devscripts. This value is used to locate files + -- produced by cabal so we can move them into the deb. Note that + -- the --builddir option of runhaskell Setup appends the "/build" + -- to the value it receives, so, yes, try not to get confused. + | DataDir FilePath + -- ^ the pathname of the package's data directory, generally the + -- value of the dataDirectory field in the PackageDescription. + | DebSourceFormat SourceFormat -- ^ Write debian/source/format + | DebWatch Text -- ^ Write debian/watch + | DHIntermediate FilePath Text -- ^ Put this text into a file with the given name in the debianization. + | DebRulesHead Text -- ^ The header of the debian/rules file. The remainder is assembled + -- from DebRulesFragment values in the atom list. + | DebRulesFragment Text -- ^ A Fragment of debian/rules + | Warning Text -- ^ A warning to be reported later + | UtilsPackageName BinPkgName -- ^ Name to give the package for left-over data files and executables + | DebChangeLog ChangeLog -- ^ The changelog, first entry contains the source package name and version + | DebLogComments [[Text]] -- ^ Each element is a comment to be added to the changelog, where the + -- element's text elements are the lines of the comment. + | SourcePackageName SrcPkgName -- ^ Name to give to debian source package. If not supplied name is constructed + -- from the cabal package name. + | DHMaintainer NameAddr -- ^ Value for the maintainer field in the control file. Note that + -- the cabal maintainer field can have multiple addresses, but debian + -- only one. If this is not explicitly set, it is obtained from the + -- cabal file, and if it is not there then from the environment. As a + -- last resort, there is a hard coded string in here somewhere. + | DHCabalFlagAssignments (Set (FlagName, Bool)) -- ^ Flags to pass to Cabal function finalizePackageDescription, this + -- can be used to control the flags in the cabal file. + | DHFlags Flags -- ^ Information regarding mode of operation - verbosity, dry-run, usage, etc + | DebRevision String -- ^ Specify the revision string to use when converting the cabal + -- version to debian. + + | OmitLTDeps -- ^ If present, don't generate the << dependency when we see a cabal + -- equals dependency. (The implementation of this was somehow lost.) + | DebVersion DebianVersion -- ^ Specify the exact debian version of the resulting package, + -- including epoch. One use case is to work around the the + -- "buildN" versions that are often uploaded to the debian and + -- ubuntu repositories. Say the latest cabal version of + -- transformers is 0.3.0.0, but the debian repository contains + -- version 0.3.0.0-1build3, we need to specify + -- debVersion="0.3.0.0-1build3" or the version we produce will + -- look older than the one already available upstream. + | DebVersionSplits [VersionSplits] -- ^ Instances where the debian package name is different (for + -- some range of version numbers) from the default constructed + -- by mkPkgName. + | BuildDep BinPkgName -- ^ Add a build dependency (FIXME: should be a Rel, or an OrRelation, not a BinPkgName) + | BuildDepIndep BinPkgName -- ^ Add an arch independent build dependency + | MissingDependency BinPkgName -- ^ Lets cabal-debian know that a package it might expect to exist + -- actually does not, so omit all uses in resulting debianization. + | ExtraLibMapping String BinPkgName -- ^ Map a cabal Extra-Library name to a debian binary package name, + -- e.g. @ExtraLibMapping extraLibMap "cryptopp" "libcrypto-dev"@ adds a + -- build dependency on @libcrypto-dev@ to any package that has @cryptopp@ + -- in its cabal Extra-Library list. + | ExecMapping String BinPkgName -- ^ Map a cabal Build-Tool name to a debian binary package name, + -- e.g. @ExecMapping "trhsx" "haskell-hsx-utils"@ adds a build + -- dependency on @haskell-hsx-utils@ to any package that has @trhsx@ in its + -- cabal build-tool list. + | EpochMapping PackageName Int -- ^ Specify epoch numbers for the debian package generated from a + -- cabal package. Example: @EpochMapping (PackageName "HTTP") 1@. + | DebPackageInfo PackageInfo -- ^ Supply some info about a cabal package. + | DebCompat Int -- ^ The debhelper compatibility level, from debian/compat. + | DebCopyright (Either License Text) -- ^ Copyright information, either as a Cabal License value or + -- the full text. + | DebControl SourceDebDescription -- ^ The parsed contents of the control file + + -- From here down are atoms to be associated with a Debian binary + -- package. This could be done with more type safety, separate + -- maps for the Source atoms and the Binary atoms. + | DHApacheSite String FilePath Text -- ^ Have Apache configure a site using PACKAGE, DOMAIN, LOGDIR, and APACHECONFIGFILE + | DHLogrotateStanza Text -- ^ Add a stanza of a logrotate file to the binary package + | DHLink FilePath FilePath -- ^ Create a symbolic link in the binary package + | DHPostInst Text -- ^ Script to run after install, should contain #DEBHELPER# line before exit 0 + | DHPostRm Text -- ^ Script to run after remove, should contain #DEBHELPER# line before exit 0 + | DHPreInst Text -- ^ Script to run before install, should contain #DEBHELPER# line before exit 0 + | DHPreRm Text -- ^ Script to run before remove, should contain #DEBHELPER# line before exit 0 + | DHArch PackageArchitectures -- ^ Set the Architecture field of source or binary + | DHPriority PackagePriority -- ^ Set the Priority field of source or binary + | DHSection Section -- ^ Set the Section field of source or binary + | DHDescription Text -- ^ Set the description of source or binary + | DHInstall FilePath FilePath -- ^ Install a build file into the binary package + | DHInstallTo FilePath FilePath -- ^ Install a build file into the binary package at an exact location + | DHInstallData FilePath FilePath -- ^ DHInstallTo somewhere relative to DataDir (see above) + | DHFile FilePath Text -- ^ Create a file with the given text at the given path + | DHInstallCabalExec String FilePath -- ^ Install a cabal executable into the binary package + | DHInstallCabalExecTo String FilePath -- ^ Install a cabal executable into the binary package at an exact location + | DHInstallDir FilePath -- ^ Create a directory in the binary package + | DHInstallInit Text -- ^ Add an init.d file to the binary package + | DHExecutable InstallFile -- ^ Create a binary package to hold a cabal executable + | DHServer Server -- ^ Like DHExecutable, but configure the executable as a server process + | DHWebsite Site -- ^ Like DHServer, but configure the server as a web server + | DHBackups String -- ^ Configure the executable to do incremental backups + | Depends Relation -- ^ Says that the debian package should have this relation in Depends + | Conflicts Relation -- ^ Says that the debian package should have this relation in Conflicts + | DevDepends BinPkgName -- ^ Limited version of Depends, put a dependency on the dev library package. The only + -- reason to use this is because we don't yet know the name of the dev library package. + deriving (Eq, Ord, Show, Typeable) + +-- | This record supplies information about the task we want done - +-- debianization, validataion, help message, etc. +data Flags = Flags + { + ------------------------- + -- Modes of Operation --- + ------------------------- + verbosity_ :: Int + -- ^ Run with progress messages at the given level of verboseness. + , dryRun_ :: Bool + -- ^ Don't write any files or create any directories, just explain + -- what would have been done. + , validate_ :: Bool + -- ^ Fail if the debianization already present doesn't match the + -- one we are going to generate closely enough that it is safe to + -- debianize during the run of dpkg-buildpackage, when Setup + -- configure is run. Specifically, the version number in the top + -- changelog entry must match, and the sets of package names in + -- the control file must match. + , debAction_ :: DebAction + -- ^ What to do - Usage, Debianize or Substvar + } deriving (Eq, Ord, Show) + +-- | Bits and pieces of information about the mapping from cabal package +-- names and versions to debian package names and versions. In essence, +-- an 'Atoms' value represents a package's debianization. The lenses in +-- this module are used to get and set the values hidden in this Atoms +-- value. Many of the values should be left alone to be set when the +-- debianization is finalized. +newtype Atoms = Atoms (Map DebAtomKey (Set DebAtom)) deriving (Eq, Show) + +instance Monoid Atoms where + -- We need mempty to actually be an empty map because we test for + -- this in the expandAtoms recursion. + mempty = Atoms mempty -- defaultAtoms + mappend a b = foldAtoms insertAtom a b + +-- Lenses to access values in the Atoms type. This is an old +-- design which I plan to make private and turn into something +-- nicer, so these will remain ugly and repetitive for now. + +-- | Set how much progress messages get generated. +verbosity :: Lens Atoms Int +verbosity = lens (\ a -> verbosity_ (getL flags a)) (\ b a -> modL flags (\ x -> x {verbosity_ = b}) a) + +-- | Don't write anything, just output a description of what would have happened +dryRun :: Lens Atoms Bool +dryRun = lens (\ a -> dryRun_ (getL flags a)) (\ b a -> modL flags (\ x -> x {dryRun_ = b}) a) + +-- | Make sure the version number and package names of the generated debianization match the +validate :: Lens Atoms Bool +validate = lens (\ a -> validate_ (getL flags a)) (\ b a -> modL flags (\ x -> x {validate_ = b}) a) + +-- | Debianize, SubstVars, or Usage. I'm no longer sure what SubstVars does, but someone +-- may still be using it. +debAction :: Lens Atoms DebAction +debAction = lens (\ a -> debAction_ (getL flags a)) (\ b a -> modL flags (\ x -> x {debAction_ = b}) a) + +-- | Obsolete record containing verbosity, dryRun, validate, and debAction. +flags :: Lens Atoms Flags +flags = lens g s + where + g atoms = fromMaybe defaultFlags $ foldAtoms from Nothing atoms + where + from Source (DHFlags x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x') + from Source (DHFlags x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DHFlags) x)) atoms + where + f Source (DHFlags y) = Just y + f _ _ = Nothing + +-- | Unused +warning :: Lens Atoms (Set Text) +warning = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (Warning t) x = Set.insert t x + from _ _ x = x + s x atoms = Set.fold (\ text atoms' -> insertAtom Source (Warning text) atoms') (deleteAtoms p atoms) x + where + p Source (Warning _) = True + p _ _ = False + + +-- | Set the compiler version, this is used when loading the cabal file to +compilerVersion :: Lens Atoms (Maybe Version) +compilerVersion = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (CompilerVersion x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (CompilerVersion x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . CompilerVersion) x)) atoms + where + f Source (CompilerVersion y) = Just y + f _ _ = Nothing + +-- | The information loaded from the cabal file. +packageDescription :: Lens Atoms (Maybe PackageDescription) +packageDescription = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHPackageDescription x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DHPackageDescription x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPackageDescription) x)) atoms + where + f Source (DHPackageDescription y) = Just y + f _ _ = Nothing + +-- | The build directory. This can be set by an argument to the @Setup@ script. +-- When @Setup@ is run manually it is just @dist@, when it is run by +-- @dpkg-buildpackage@ the compiler name is appended, so it is typically +-- @dist-ghc@. Cabal-debian needs the correct value of buildDir to find +-- the build results. +buildDir :: Lens Atoms (Maybe FilePath) +buildDir = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (BuildDir x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (BuildDir x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . BuildDir) x)) atoms + where + f Source (BuildDir y) = Just y + f _ _ = Nothing + +-- | The data directory for the package, generated from the packageDescription +dataDir :: Lens Atoms (Maybe FilePath) +dataDir = lens g s + where + g atoms = + fmap (\ p -> let PackageName pkgname = pkgName. package $ p in + "usr/share" (pkgname ++ "-" ++ (showVersion . pkgVersion . package $ p))) (getL packageDescription atoms) + s _ _ = error "setL dataDir" + + +-- | The Compiler value returned when the cabal file was loaded. +compiler :: Lens Atoms (Maybe Compiler) +compiler = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHCompiler x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (DHCompiler x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHCompiler) x)) atoms + where + f Source (DHCompiler y) = Just y + f _ _ = Nothing + +-- | Map from cabal Extra-Lib names to debian binary package names. +extraLibMap :: Lens Atoms (Map String (Set BinPkgName)) +extraLibMap = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from Source (ExtraLibMapping cabal debian) x = Map.insertWith union cabal (singleton debian) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ cabal debian atoms' -> Set.fold (\ debian' atoms'' -> insertAtom Source (ExtraLibMapping cabal debian') atoms'') atoms' debian) (deleteAtoms p atoms) x + where + p Source (ExtraLibMapping _ _) = True + p _ _ = False + +-- | Map from cabal Build-Tool names to debian binary package names. +execMap :: Lens Atoms (Map String BinPkgName) +execMap = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from Source (ExecMapping cabal debian) x = Map.insertWith (error "Conflict in execMap") cabal debian x + from _ _ x = x + s x atoms = Map.foldWithKey (\ cabal debian atoms' -> insertAtom Source (ExecMapping cabal debian) atoms') (deleteAtoms p atoms) x + where + p Source (ExecMapping _ _) = True + p _ _ = False + +-- | Cabal flag assignments to use when loading the cabal file. +cabalFlagAssignments :: Lens Atoms (Set (FlagName, Bool)) +cabalFlagAssignments = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (DHCabalFlagAssignments pairs) x = union pairs x + from _ _ x = x + s x atoms = insertAtom Source (DHCabalFlagAssignments x) (deleteAtoms p atoms) + where + p Source (DHCabalFlagAssignments _) = True + p _ _ = False + +-- | Map from cabal version number ranges to debian package names. This is a +-- result of the fact that only one version of a debian package can be +-- installed at a given time, while multiple versions of a cabal packages can. +versionSplits :: Lens Atoms [VersionSplits] +versionSplits = lens g s + where + g atoms = foldAtoms from [] atoms + where + from Source (DebVersionSplits xs') xs = xs ++ xs' + from _ _ xs = xs + s x atoms = insertAtom Source (DebVersionSplits x) (deleteAtoms p atoms) + where + p Source (DebVersionSplits _) = True + p _ _ = False + +-- | Map of Debian epoch numbers assigned to cabal packages. +epochMap :: Lens Atoms (Map PackageName Int) +epochMap = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from Source (EpochMapping name epoch) x = Map.insertWith (error "Conflicting Epochs") name epoch x + from _ _ x = x + s x atoms = Map.foldWithKey (\ name epoch atoms' -> insertAtom Source (EpochMapping name epoch) atoms') (deleteAtoms p atoms) x + where + p Source (EpochMapping _ _) = True + p _ _ = False + +-- | Map of binary deb descriptions. +description :: Lens Atoms (Map BinPkgName Text) +description = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHDescription d) x = Map.insertWith (error "description") b d x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHDescription y) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHDescription _) = True + p _ _ = False + +-- | Create a package to hold a cabal executable +executable :: Lens Atoms (Map BinPkgName InstallFile) +executable = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHExecutable f) x = Map.insertWith (error "executable") b f x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHExecutable y) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHExecutable _) = True + p _ _ = False + +-- | Create a package for an operating service using the given executable +serverInfo :: Lens Atoms (Map BinPkgName Server) +serverInfo = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHServer s) x = Map.insertWith (error "server") b s x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHServer y) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHServer _) = True + p _ _ = False + +-- | Create a package for a website using the given executable as the server +website :: Lens Atoms (Map BinPkgName Site) +website = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHWebsite s) x = Map.insertWith (error "website") b s x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHWebsite y) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHWebsite _) = True + p _ _ = False + +-- | Generate a backups package using the given cabal executable +backups :: Lens Atoms (Map BinPkgName String) +backups = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHBackups s) x = Map.insertWith (error "backups") b s x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHBackups y) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHBackups _) = True + p _ _ = False + +-- | Create an apache configuration file with the given +-- (domain, logdir, filetext). This is called when expanding +-- the result of the website lens above. +apacheSite :: Lens Atoms (Map BinPkgName (String, FilePath, Text)) +apacheSite = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHApacheSite dom log text) x = Map.insertWith (error "backups") b (dom, log, text) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b (dom, log, text) atoms' -> insertAtom (Binary b) (DHApacheSite dom log text) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHApacheSite _ _ _) = True + p _ _ = False + +-- * Lower level hints about the debianization + + +-- | List if packages that should be omitted from any +-- dependency list - e.g. a profiling package missing due +-- to use of noProfilingPackage lens elsewhere. +missingDependencies :: Lens Atoms (Set BinPkgName) +missingDependencies = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (MissingDependency b) x = Set.insert b x + from _ _ x = x + s x atoms = Set.fold (\ b atoms' -> insertAtom Source (MissingDependency b) atoms') (deleteAtoms p atoms) x + where + p Source (MissingDependency _) = True + p _ _ = False + +-- | Override the package name used to hold left over data files and executables +utilsPackageName :: Lens Atoms (Maybe BinPkgName) +utilsPackageName = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (UtilsPackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (UtilsPackageName x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . UtilsPackageName) x)) atoms + where + f Source (UtilsPackageName y) = Just y + f _ _ = Nothing + +-- | Override the debian source package name constructed from the cabal name +sourcePackageName :: Lens Atoms (Maybe SrcPkgName) +sourcePackageName = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (SourcePackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (SourcePackageName x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . SourcePackageName) x)) atoms + where + f Source (SourcePackageName y) = Just y + f _ _ = Nothing + +-- | Revision string used in constructing the debian verison number from the cabal version +revision :: Lens Atoms (Maybe String) +revision = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebRevision x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DebRevision x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRevision) x)) atoms + where + f Source (DebRevision y) = Just y + f _ _ = Nothing + +-- | Exact debian version number, overrides the version generated from the cabal version +debVersion :: Lens Atoms (Maybe DebianVersion) +debVersion = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebVersion x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DebVersion x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebVersion) x)) atoms + where + f Source (DebVersion y) = Just y + f _ _ = Nothing + +-- | Maintainer field. Overrides any value found in the cabal file, or +-- in the DEBIANMAINTAINER environment variable. +maintainer :: Lens Atoms (Maybe NameAddr) +maintainer = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHMaintainer x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DHMaintainer x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHMaintainer) x)) atoms + where + f Source (DHMaintainer y) = Just y + f _ _ = Nothing + +-- | No longer sure what the purpose of this lens is. +packageInfo :: Lens Atoms (Map PackageName PackageInfo) +packageInfo = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from Source (DebPackageInfo i) x = Map.insert (cabalName i) i x + from _ _ x = x + s x atoms = + Map.fold (\ i atoms' -> insertAtom Source (DebPackageInfo i) atoms') (deleteAtoms p atoms) x + where + p Source (DebPackageInfo _) = True + p _ _ = False + +-- | Set this to filter any less-than dependencies out of the generated debian +-- dependencies. (Not sure if this is implemented.) +omitLTDeps :: Lens Atoms Bool +omitLTDeps = lens g s + where + g atoms = foldAtoms from False atoms + where + from Source OmitLTDeps _ = True + from _ _ x = x + s x atoms = (if x then insertAtom Source OmitLTDeps else id) (deleteAtoms p atoms) + where + p Source OmitLTDeps = True + p _ _ = False + +-- | Set this to omit the prof library deb. +noProfilingLibrary :: Lens Atoms Bool +noProfilingLibrary = lens g s + where + g atoms = foldAtoms from False atoms + where + from Source NoProfilingLibrary _ = True + from _ _ x = x + s x atoms = (if x then insertAtom Source NoProfilingLibrary else id) (deleteAtoms p atoms) + where + p Source NoProfilingLibrary = True + p _ _ = False + +-- | Set this to omit the doc library deb. +noDocumentationLibrary :: Lens Atoms Bool +noDocumentationLibrary = lens g s + where + g atoms = foldAtoms from False atoms + where + from Source NoDocumentationLibrary _ = True + from _ _ x = x + s x atoms = (if x then insertAtom Source NoDocumentationLibrary else id) (deleteAtoms p atoms) + where + p Source NoDocumentationLibrary = True + p _ _ = False + +-- | The copyright information +copyright :: Lens Atoms (Maybe (Either License Text)) +copyright = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebCopyright x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DebCopyright x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCopyright) x)) atoms + where + f Source (DebCopyright y) = Just y + f _ _ = Nothing + +-- | The source package architecture - @Any@, @All@, or some list of specific architectures. +sourceArchitecture :: Lens Atoms (Maybe PackageArchitectures) +sourceArchitecture = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHArch x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DHArch x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHArch) x)) atoms + where + f Source (DHArch y) = Just y + f _ _ = Nothing + +-- | Map of the binary package architectures +binaryArchitectures :: Lens Atoms (Map BinPkgName PackageArchitectures) +binaryArchitectures = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHArch x) m = Map.insert b x m + from _ _ m = m + s x atoms = Map.foldWithKey (\ b a atoms' -> insertAtom (Binary b) (DHArch a) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHArch _) = True + p _ _ = False + +-- | The source package priority +sourcePriority :: Lens Atoms (Maybe PackagePriority) +sourcePriority = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHPriority x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DHPriority x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPriority) x)) atoms + where + f Source (DHPriority y) = Just y + f _ _ = Nothing + +-- | Map of the binary package priorities +binaryPriorities :: Lens Atoms (Map BinPkgName PackagePriority) +binaryPriorities = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHPriority p) x = Map.insertWith (error "priorities") b p x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b p atoms'-> insertAtom (Binary b) (DHPriority p) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHPriority _) = True + p _ _ = False + +-- | The source package's section assignment +sourceSection :: Lens Atoms (Maybe Section) +sourceSection = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DHSection x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DHSection x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHSection) x)) atoms + where + f Source (DHSection y) = Just y + f _ _ = Nothing + +-- | Map of the binary deb section assignments +binarySections :: Lens Atoms (Map BinPkgName Section) +binarySections = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHSection p) x = Map.insertWith (error "sections") b p x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b p atoms'-> insertAtom (Binary b) (DHSection p) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHSection _) = True + p _ _ = False + +-- * Debian dependency info + +-- | Build dependencies +buildDeps :: Lens Atoms (Set BinPkgName) +buildDeps = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (BuildDep d) x = Set.insert d x + from _ _ x = x + s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDep d) atoms') (deleteAtoms p atoms) x + where + p Source (BuildDep _) = True + p _ _ = False + +-- | Architecture independent +buildDepsIndep :: Lens Atoms (Set BinPkgName) +buildDepsIndep = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (BuildDepIndep d) x = Set.insert d x + from _ _ x = x + s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) x + where + p Source (BuildDepIndep _) = True + p _ _ = False + +-- | Map of extra install dependencies for the package's binary debs. +-- This should be [[Relation]] for full generality, or Set (Set Relation) +depends :: Lens Atoms (Map BinPkgName (Set Relation)) +depends = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (Depends rel) x = Map.insertWith union b (singleton rel) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Depends rel) atoms'') atoms' rels) (deleteAtoms p atoms) x + where + p (Binary _) (Depends _) = True + p _ _ = False + +-- | Map of extra install conflicts for the package's binary debs. +-- We should support all the other dependency fields - provides, replaces, etc. +conflicts :: Lens Atoms (Map BinPkgName (Set Relation)) +conflicts = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (Conflicts rel) x = Map.insertWith union b (singleton rel) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Conflicts rel) atoms'') atoms' rels) (deleteAtoms p atoms) x + where + p (Binary _) (Conflicts _) = True + p _ _ = False + +-- | Extra install dependencies for the devel library. Redundant +-- with depends, but kept for backwards compatibility. Also, I +-- think maybe this is or was needed because it can be set before +-- the exact name of the library package is known. +extraDevDeps :: Lens Atoms (Set BinPkgName) +extraDevDeps = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (DevDepends b) x = Set.insert b x + from _ _ x = x + s x atoms = Set.fold (\ d atoms' -> insertAtom Source (DevDepends d) atoms') (deleteAtoms p atoms) x + where + p Source (DevDepends _) = True + p _ _ = False + +-- | The beginning of the rules file +rulesHead :: Lens Atoms (Maybe Text) +rulesHead = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebRulesHead x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') + from Source (DebRulesHead x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRulesHead) x)) atoms + where + f Source (DebRulesHead y) = Just y + f _ _ = Nothing + +-- | Additional fragments of the rules file +rulesFragments :: Lens Atoms (Set Text) +rulesFragments = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (DebRulesFragment t) x = Set.insert t x + from _ _ x = x + s x atoms = Set.fold (\ text atoms' -> insertAtom Source (DebRulesFragment text) atoms') (deleteAtoms p atoms) x + where + p Source (DebRulesFragment _) = True + p _ _ = False + +-- | Map of @debian/postinst@ scripts +postInst :: Lens Atoms (Map BinPkgName Text) +postInst = lens g s + where + g atoms = foldAtoms from mempty atoms + where + from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text + from (Binary b) (DHPostInst t) x = Map.insertWith (error "Conflicting postInsts") b t x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostInst t) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHPostInst _) = True + p _ _ = False + +-- | Map of @debian/postrm@ scripts +postRm :: Lens Atoms (Map BinPkgName Text) +postRm = lens g s + where + g atoms = foldAtoms from mempty atoms + where + from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text + from (Binary b) (DHPostRm t) m = Map.insertWith (error "Conflicting postRms") b t m + from _ _ x = x + s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostRm t) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHPostRm _) = True + p _ _ = False + +-- | Map of @debian/preinst@ scripts +preInst :: Lens Atoms (Map BinPkgName Text) +preInst = lens g s + where + g atoms = foldAtoms from mempty atoms + where + from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text + from (Binary b) (DHPreInst t) m = Map.insertWith (error "Conflicting preInsts") b t m + from _ _ x = x + s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreInst t) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHPreInst _) = True + p _ _ = False + +-- | Map of @debian/prerm@ scripts +preRm :: Lens Atoms (Map BinPkgName Text) +preRm = lens g s + where + g atoms = foldAtoms from mempty atoms + where + from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text + from (Binary b) (DHPreRm t) m = Map.insertWith (error "Conflicting preRms") b t m + from _ _ x = x + s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreRm t) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHPreRm _) = True + p _ _ = False + +-- | The @debian/compat@ file, contains the minimum compatible version of the @debhelper@ package +compat :: Lens Atoms (Maybe Int) +compat = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebCompat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (DebCompat x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCompat) x)) atoms + where + f Source (DebCompat y) = Just y + f _ _ = Nothing + +-- | The @debian/source/format@ file. +sourceFormat :: Lens Atoms (Maybe SourceFormat) +sourceFormat = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebSourceFormat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (DebSourceFormat x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebSourceFormat) x)) atoms + where + f Source (DebSourceFormat y) = Just y + f _ _ = Nothing + +-- | the @debian/watch@ file +watch :: Lens Atoms (Maybe Text) +watch = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebWatch x') (Just x) | x /= x' = error $ "Conflicting watch values:" ++ show (x, x') + from Source (DebWatch x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebWatch) x)) atoms + where + f Source (DebWatch y) = Just y + f _ _ = Nothing + +-- | the @debian/changelog@ file +changelog :: Lens Atoms (Maybe ChangeLog) +changelog = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebChangeLog x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') + from Source (DebChangeLog x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebChangeLog) x)) atoms + where + f Source (DebChangeLog y) = Just y + f _ _ = Nothing + +-- | Comment entries for the latest changelog entry (DebLogComments [[Text]]) +comments :: Lens Atoms (Maybe [[Text]]) +comments = lens g s + where + g atoms = foldAtoms from Nothing atoms + where + from Source (DebLogComments xss') (Just xss) | xss == xss' = error $ "Conflicting log comments: " ++ show (xss, xss') + from Source (DebLogComments xss) _ = Just xss + from _ _ x = x + s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebLogComments) x)) atoms + where + f Source (DebLogComments y) = Just y + f _ _ = Nothing + +-- | The @debian/control@ file. +control :: Lens Atoms SourceDebDescription +control = lens g s + where + g atoms = fromMaybe newSourceDebDescription $ foldAtoms from Nothing atoms + where + from Source (DebControl x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x') + from Source (DebControl x) _ = Just x + from _ _ x = x + s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DebControl) x)) atoms + where + f Source (DebControl y) = Just y + f _ _ = Nothing + +-- | The @Standards-Version@ field of the @debian/control@ file +standards :: Lens Atoms (Maybe StandardsVersion) +standards = lens (\ a -> standardsVersion (getL control a)) (\ b a -> modL control (\ x -> x {standardsVersion = b}) a) +logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text)) +logrotateStanza = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHLogrotateStanza r) x = Map.insertWith Set.union b (singleton r) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b ts atoms'-> Set.fold (\ t atoms'' -> insertAtom (Binary b) (DHLogrotateStanza t) atoms'') atoms' ts) (deleteAtoms p atoms) x + where + p (Binary _) (DHLogrotateStanza _) = True + p _ _ = False +link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +link = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHLink loc txt) x = Map.insertWith Set.union b (singleton (loc, txt)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (loc, txt) atoms'' -> insertAtom (Binary b) (DHLink loc txt) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHLink _ _) = True + p _ _ = False + +-- | Install files into directories +install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +install = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstall src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstall src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstall _ _) = True + p _ _ = False + +-- | Rename and install files +installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +installTo = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallTo src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallTo src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallTo _ _) = True + p _ _ = False + +-- | Install files into the package data directory +installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +installData = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallData src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallData src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallData _ _) = True + p _ _ = False + +-- | Create a file in the deb with the given text +file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text))) +file = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHFile path text) x = Map.insertWith Set.union b (singleton (path, text)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (path, text) atoms'' -> insertAtom (Binary b) (DHFile path text) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHFile _ _) = True + p _ _ = False + +-- | Install a cabal executable +installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) +installCabalExec = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallCabalExec name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExec name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallCabalExec _ _) = True + p _ _ = False + +-- | Rename and install a cabal executable +installCabalExecTo :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) +installCabalExecTo = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallCabalExecTo name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExecTo name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallCabalExecTo _ _) = True + p _ _ = False + +-- | Create directories in the package +installDir :: Lens Atoms (Map BinPkgName (Set FilePath)) +installDir = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallDir path) x = Map.insertWith Set.union b (singleton path) x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b paths atoms'-> Set.fold (\ path atoms'' -> insertAtom (Binary b) (DHInstallDir path) atoms'') atoms' paths) (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallDir _) = True + p _ _ = False + +-- | Create an /etc/init.d file in the package +installInit :: Lens Atoms (Map BinPkgName Text) +installInit = lens g s + where + g atoms = foldAtoms from Map.empty atoms + where + from (Binary b) (DHInstallInit text) x = Map.insertWith (error "installInit") b text x + from _ _ x = x + s x atoms = Map.foldWithKey (\ b text atoms'-> insertAtom (Binary b) (DHInstallInit text) atoms') (deleteAtoms p atoms) x + where + p (Binary _) (DHInstallInit _) = True + p _ _ = False + +-- | Create a file in the debianization. This is used to implement the file lens above. +intermediateFiles :: Lens Atoms (Set (FilePath, Text)) +intermediateFiles = lens g s + where + g atoms = foldAtoms from Set.empty atoms + where + from Source (DHIntermediate path text) x = Set.insert (path, text) x + from _ _ x = x + s x atoms = Set.fold (\ (path, text) atoms' -> insertAtom Source (DHIntermediate path text) atoms') (deleteAtoms p atoms) x + where + p Source (DHIntermediate _ _) = True + p _ _ = False + +defaultFlags :: Flags +defaultFlags = + Flags { + verbosity_ = 1 + , debAction_ = Usage + , dryRun_ = False + , validate_ = False + } + +insertAtom :: DebAtomKey -> DebAtom -> Atoms -> Atoms +insertAtom mbin atom (Atoms x) = Atoms (insertWith union mbin (singleton atom) x) + +insertAtoms :: Set (DebAtomKey, DebAtom) -> Atoms -> Atoms +insertAtoms s atoms = + case maxView s of + Nothing -> atoms + Just ((k, a), s') -> insertAtoms s' (insertAtom k a atoms) + +foldAtoms :: (DebAtomKey -> DebAtom -> r -> r) -> r -> Atoms -> r +foldAtoms f r0 (Atoms xs) = Map.foldWithKey (\ k s r -> Set.fold (f k) r s) r0 xs + +-- | Split atoms out of an Atoms by predicate. +partitionAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> (Set (DebAtomKey, DebAtom), Atoms) +partitionAtoms f deb = + foldAtoms g (mempty, Atoms mempty) deb + where + g k atom (atoms, deb') = + case f k atom of + True -> (Set.insert (k, atom) atoms, deb') + False -> (atoms, insertAtom k atom deb') + +deleteAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> Atoms +deleteAtoms p atoms = snd (partitionAtoms p atoms) + +-- | Split atoms out of a Atoms by predicate. +partitionAtoms' :: (Ord a) => (DebAtomKey -> DebAtom -> Maybe a) -> Atoms -> (Set a, Atoms) +partitionAtoms' f deb = + foldAtoms g (mempty, Atoms mempty) deb + where + g k atom (xs, deb') = + case f k atom of + Just x -> (Set.insert x xs, deb') + Nothing -> (xs, insertAtom k atom deb') + +-- | Like modifyAtoms, but... +modifyAtoms' :: (Ord a) => + (DebAtomKey -> DebAtom -> Maybe a) + -> (Set a -> Set (DebAtomKey, DebAtom)) + -> Atoms + -> Atoms +modifyAtoms' f g atoms = + insertAtoms (g s) atoms' + where + (s, atoms') = partitionAtoms' f atoms diff --git a/src/Debian/Debianize/Bundled.hs b/src/Debian/Debianize/Bundled.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Bundled.hs @@ -0,0 +1,388 @@ +-- | Determine whether a specific version of a Haskell package is +-- bundled with into this particular version of the given compiler. + +{-# LANGUAGE StandaloneDeriving #-} +module Debian.Debianize.Bundled + ( ghcBuiltIn + ) where + +import qualified Data.Map as Map +import Data.Set (fromList, member) +import Data.Version (Version(..)) +import Debian.Relation.ByteString() +import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-}) +import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-}) + +type Bundled = (CompilerFlavor, Version, [PackageIdentifier]) + +-- |Return a list of built in packages for the compiler in an environment. +-- ghcBuiltIns :: FilePath -> IO [PackageIdentifier] +-- ghcBuiltIns root = +-- fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>= +-- return . map parsePackageIdentifier . words . unpack . fst . collectStdout +-- where +-- parsePackageIdentifier s = +-- let (v', n') = break (== '-') (reverse s) +-- (v, n) = (reverse (tail n'), reverse v') in +-- PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) []) + +ghcBuiltIns :: Compiler -> Bundled +ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) = + case Map.lookup compilerVersion + (Map.fromList (map (\ (cmp, ver, lst) -> (ver, (cmp, ver, lst))) + [ (GHC, Version [7,6,1] [], ghc761BuiltIns) + , (GHC, Version [7,6,1,20121207] [], ghc761BuiltIns) + , (GHC, Version [7,4,1] [], ghc741BuiltIns) + , (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns) + , (GHC, Version [7,4,0,20120108] [], ghc740BuiltIns) + , (GHC, Version [7,2,2] [], ghc721BuiltIns) + , (GHC, Version [7,2,1] [], ghc721BuiltIns) + , (GHC, Version [7,0,4] [], ghc701BuiltIns) + , (GHC, Version [7,0,3] [], ghc701BuiltIns) + , (GHC, Version [7,0,1] [], ghc701BuiltIns) + , (GHC, Version [6,8,3] [], ghc683BuiltIns) + , (GHC, Version [6,8,2] [], ghc682BuiltIns) + , (GHC, Version [6,8,1] [], ghc681BuiltIns) + , (GHC, Version [6,6,1] [], ghc661BuiltIns) + , (GHC, Version [6,6] [], ghc66BuiltIns) ])) of + Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion + Just x -> x +ghcBuiltIns (Compiler {compilerId = _}) = error "ghcBuiltIns: Only GHC is supported" + +ghcBuiltIn :: Compiler -> PackageName -> Bool +ghcBuiltIn compiler package = + Data.Set.member + package + (Data.Set.fromList + (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -} + (_, _, xs) = ghcBuiltIns compiler in map pkgName xs)) + +v :: String -> [Int] -> PackageIdentifier +v n x = PackageIdentifier (PackageName n) (Version x []) + +-- Removed: rts, extensible-exceptions +ghc761BuiltIns :: [PackageIdentifier] +ghc761BuiltIns = [ + v "array" [0,4,0,1], + v "base" [4,6,0,1], + v "binary" [0,5,1,1], + v "bin-package-db" [0,0,0,0], + v "bytestring" [0,10,0,2], + v "Cabal" [1,16,0], + v "containers" [0,5,0,0], + v "deepseq" [1,3,0,1], + v "directory" [1,2,0,1], + v "filepath" [1,3,0,1], + v "ghc" [7,6,1,20121207], + v "ghc-prim" [0,3,0,0], + v "haskell2010" [1,1,1,0], + v "haskell98" [2,0,0,2], + v "hoopl" [3,9,0,0], + v "hpc" [0,6,0,0], + v "integer-gmp" [0,5,0,0], + v "old-locale" [1,0,0,5], + v "old-time" [1,1,0,1], + v "pretty" [1,1,1,0], + v "process" [1,1,0,2], + v "template-haskell" [2,8,0,0], + v "time" [1,4,0,1], + v "unix" [2,6,0,1] + ] + +-- | Packages bundled with 7.4.0.20111219-2. +ghc741BuiltIns :: [PackageIdentifier] +ghc741BuiltIns = [ + v "Cabal" [1,14,0], + v "array" [0,4,0,0], + v "base" [4,5,0,0], + v "bin-package-db" [0,0,0,0], + v "binary" [0,5,1,0], + v "bytestring" [0,9,2,1], + v "containers" [0,4,2,1], + v "deepseq" [1,3,0,0], + v "directory" [1,1,0,2], + v "extensible-exceptions" [0,1,1,4], + v "filepath" [1,3,0,0], + v "ghc" [7,4,1], + v "ghc-prim" [0,2,0,0], + v "haskell2010" [1,1,0,1], + v "haskell98" [2,0,0,1], + v "hoopl" [3,8,7,2], + v "hpc" [0,5,1,1], + v "integer-gmp" [0,4,0,0], + v "old-locale" [1,0,0,4], + v "old-time" [1,1,0,0], + v "pretty" [1,1,1,0], + v "process" [1,1,0,1], + v "rts" [1,0], + v "template-haskell" [2,7,0,0], + v "time" [1,4], + v "unix" [2,5,1,0] ] + +-- | Packages bundled with 7.4.0.20111219-2. +ghc740BuiltIns :: [PackageIdentifier] +ghc740BuiltIns = [ + v "Cabal" [1,14,0], + v "array" [0,4,0,0], + v "base" [4,5,0,0], + v "bin-package-db" [0,0,0,0], + v "binary" [0,5,1,0], + v "bytestring" [0,9,2,1], + v "containers" [0,4,2,1], + v "deepseq" [1,3,0,0], + v "directory" [1,1,0,2], + v "extensible-exceptions" [0,1,1,4], + v "filepath" [1,3,0,0], + v "ghc" [7,4,0,20111219], + v "ghc-prim" [0,2,0,0], + v "haskell2010" [1,1,0,1], + v "haskell98" [2,0,0,1], + v "hoopl" [3,8,7,2], + v "hpc" [0,5,1,1], + v "integer-gmp" [0,4,0,0], + v "old-locale" [1,0,0,4], + v "old-time" [1,1,0,0], + v "pretty" [1,1,1,0], + v "process" [1,1,0,1], + v "rts" [1,0], + v "template-haskell" [2,7,0,0], + v "time" [1,4], + v "unix" [2,5,1,0] ] + +ghc721BuiltIns :: [PackageIdentifier] +ghc721BuiltIns = [ + v "Cabal" [1,12,0], + v "array" [0,3,0,3], + v "base" [4,4,0,0], + v "bin-package-db" [0,0,0,0], + v "binary" [0,5,0,2], + v "bytestring" [0,9,2,0], + v "containers" [0,4,1,0], + v "directory" [1,1,0,1], + v "extensible-exceptions" [0,1,1,3], + v "filepath" [1,2,0,1], + v "ghc" [7,2,1], + -- ghc-binary renamed to binary + v "ghc-prim" [0,2,0,0], + v "haskell2010" [1,1,0,0], + v "haskell98" [2,0,0,0], + v "hoopl" [3,8,7,1], -- new + v "hpc" [0,5,1,0], + v "integer-gmp" [0,3,0,0], + v "old-locale" [1,0,0,3], + v "old-time" [1,0,0,7], + v "pretty" [1,1,0,0], + v "process" [1,1,0,0], + -- random removed + v "rts" [1,0], + v "template-haskell" [2,6,0,0], + v "time" [1,2,0,5], + v "unix" [2,5,0,0] ] + +ghc701BuiltIns :: [PackageIdentifier] +ghc701BuiltIns = [ + v "Cabal" [1,10,0,0], + v "array" [0,3,0,2], + v "base" [4,3,0,0], + v "bin-package-db" [0,0,0,0], + v "bytestring" [0,9,1,8], + v "containers" [0,4,0,0], + v "directory" [1,1,0,0], + v "extensible-exceptions" [0,1,1,2], + v "filepath" [1,2,0,0], + v "ghc" [7,0,1], + v "ghc-binary" [0,5,0,2], + v "ghc-prim" [0,2,0,0], + v "haskell2010" [1,0,0,0], + v "haskell98" [1,1,0,0], + v "hpc" [0,5,0,6], + v "integer-gmp" [0,2,0,2], + v "old-locale" [1,0,0,2], + v "old-time" [1,0,0,6], + v "pretty" [1,0,1,2], + v "process" [1,0,1,4], + v "random" [1,0,0,3], + v "rts" [1,0], + v "template-haskell" [2,5,0,0], + v "time" [1,2,0,3], + v "unix" [2,4,1,0] + ] + +ghc683BuiltIns :: [PackageIdentifier] +ghc683BuiltIns = ghc682BuiltIns + +ghc682BuiltIns :: [PackageIdentifier] +ghc682BuiltIns = [ + v "Cabal" [1,2,3,0], + v "array" [0,1,0,0], + v "base" [3,0,1,0], + v "bytestring" [0,9,0,1], + v "containers" [0,1,0,1], + v "directory" [1,0,0,0], + v "filepath" [1,1,0,0], + v "ghc" [6,8,2,0], + v "haskell98" [1,0,1,0], + v "hpc" [0,5,0,0], + v "old-locale" [1,0,0,0], + v "old-time" [1,0,0,0], + v "packedstring" [0,1,0,0], + v "pretty" [1,0,0,0], + v "process" [1,0,0,0], + v "random" [1,0,0,0], + v "readline" [1,0,1,0], + v "template-haskell" [2,2,0,0], + v "unix" [2,3,0,0] + ] + +ghc681BuiltIns :: [PackageIdentifier] +ghc681BuiltIns = [ + v "base" [3,0,0,0], + v "Cabal" [1,2,2,0], + v "GLUT" [2,1,1,1], + v "HGL" [3,2,0,0], + v "HUnit" [1,2,0,0], + v "OpenAL" [1,3,1,1], + v "OpenGL" [2,2,1,1], + v "QuickCheck" [1,1,0,0], + v "X11" [1,2,3,1], + v "array" [0,1,0,0], + v "bytestring" [0,9,0,1], + v "cgi" [3001,1,5,1], + v "containers" [0,1,0,0], + v "directory" [1,0,0,0], + v "fgl" [5,4,1,1], + v "filepatch" [1,1,0,0], + v "ghc" [6,8,1,0], + v "haskell-src" [1,0,1,1], + v "haskell98" [1,0,1,0], + v "hpc" [0,5,0,0], + v "html" [1,0,1,1], + v "mtl" [1,1,0,0], + v "network" [2,1,0,0], + v "old-locale" [1,0,0,0], + v "old-time" [1,0,0,0], + v "packedstring" [0,1,0,0], + v "parallel" [1,0,0,0], + v "parsec" [2,1,0,0], + v "pretty" [1,0,0,0], + v "process" [1,0,0,0], + v "random" [1,0,0,0], + v "readline" [1,0,1,0], + v "regex-base" [0,72,0,1], + v "regex-compat" [0,71,0,1], + v "regex-posix" [0,72,0,1], + v "stm" [2,1,1,0], + v "template-haskell" [2,2,0,0], + v "time" [1,1,2,0], + v "unix" [2,2,0,0], + v "xhtml" [3000,0,2,1] + ] + +ghc661BuiltIns :: [PackageIdentifier] +ghc661BuiltIns = [ + v "base" [2,1,1], + v "Cabal" [1,1,6,2], + v "cgi" [3001,1,1], + v "fgl" [5,4,1], + v "filepath" [1,0], + v "ghc" [6,6,1], + v "GLUT" [2,1,1], + v "haskell98" [1,0], + v "haskell-src" [1,0,1], + v "HGL" [3,1,1], + v "html" [1,0,1], + v "HUnit" [1,1,1], + v "mtl" [1,0,1], + v "network" [2,0,1], + v "OpenAL" [1,3,1], + v "OpenGL" [2,2,1], + v "parsec" [2,0], + v "QuickCheck" [1,0,1], + v "readline" [1,0], + v "regex-base" [0,72], + v "regex-compat" [0,71], + v "regex-posix" [0,71], + v "rts" [1,0], + v "stm" [2,0], + v "template-haskell" [2,1], + v "time" [1,1,1], + v "unix" [2,1], + v "X11" [1,2,1], + v "xhtml" [3000,0,2] + ] + +ghc66BuiltIns :: [PackageIdentifier] +ghc66BuiltIns = [ + v "base" [2,0], + v "Cabal" [1,1,6], + v "cgi" [2006,9,6], + v "fgl" [5,2], + v "ghc" [6,6], + v "GLUT" [2,0], + v "haskell98" [1,0], + v "haskell-src" [1,0], + v "HGL" [3,1], + v "html" [1,0], + v "HTTP" [2006,7,7], + v "HUnit" [1,1], + v "mtl" [1,0], + v "network" [2,0], + v "OpenAL" [1,3], + v "OpenGL" [2,1], + v "parsec" [2,0], + v "QuickCheck" [1,0], + v "readline" [1,0], + v "regex-base" [0,71], + v "regex-compat" [0,71], + v "regex-posix" [0,71], + v "rts" [1,0], + v "stm" [2,0], + v "template-haskell" [2,0], + v "time" [1,0], + v "unix" [1,0], + v "X11" [1,1], + v "xhtml" [2006,9,13] + ] + +-- Script to output a list of the libraries in the ghc package +-- provides line. This could be run inside the build environment +-- instead of having these hard coded lists. +-- +-- apt-cache show ghc \ +-- | grep ^Provides: \ +-- | cut -d\ -f2- +-- | sed 's/, /\n/g' \ +-- | grep libghc- \ +-- | cut -d- -f2- \ +-- | grep dev$ \ +-- | sort -u \ +-- | sed 's/-dev//;s/$/",/;s/^/"/' +-- +-- base :: Set String +-- base +-- = Data.Set.fromList +-- [ "array", +-- "base", +-- "binary", +-- "bin-package-db", +-- "bytestring", +-- "cabal", +-- "containers", +-- "deepseq", +-- "directory", +-- "extensible-exceptions", +-- "filepath", +-- "ghc-prim", +-- "haskell2010", +-- "haskell98", +-- "hoopl", +-- "hpc", +-- "integer-gmp", +-- "old-locale", +-- "old-time", +-- "pretty", +-- "process", +-- "rts", +-- "template-haskell", +-- "time", +-- "unix" ] diff --git a/src/Debian/Debianize/ControlFile.hs b/src/Debian/Debianize/ControlFile.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/ControlFile.hs @@ -0,0 +1,206 @@ +-- | Preliminary. +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} +module Debian.Debianize.ControlFile + ( SourceDebDescription(..) + , newSourceDebDescription + , newSourceDebDescription' + , VersionControlSpec(..) + , XField(..) + , XFieldDest(..) + , BinaryDebDescription(..) + , newBinaryDebDescription + , modifyBinaryDeb + -- , modifyBinaryDescription + , PackageRelations(..) + , PackageType(..) + , packageArch + ) where + +import Data.Generics (Data, Typeable) +import Data.Monoid (mempty) +import Data.Set as Set (Set, empty) +import Data.Text (Text) +import Debian.Orphans () +import Debian.Policy (StandardsVersion, PackagePriority, PackageArchitectures(..), Section) +import Debian.Relation (Relations, SrcPkgName(..), BinPkgName) +import Prelude hiding (init, log) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) + +-- | This type represents the debian/control file, which is the core +-- of the source package debianization. It includes the information +-- that goes in the first, or source, section, and then a list of the +-- succeeding binary package sections. +data SourceDebDescription + = SourceDebDescription + { source :: Maybe SrcPkgName + -- ^ + , maintainer :: Maybe NameAddr + -- ^ + , changedBy :: Maybe NameAddr + -- ^ + , uploaders :: [NameAddr] + -- ^ + , dmUploadAllowed :: Bool + -- ^ + , priority :: Maybe PackagePriority + -- ^ + , section :: Maybe Section + -- ^ + , standardsVersion :: Maybe StandardsVersion + -- ^ + , homepage :: Maybe Text + -- ^ + , vcsFields :: Set VersionControlSpec + -- ^ + , xFields :: Set XField + -- ^ + , buildDepends :: Relations + , buildConflicts :: Relations + , buildDependsIndep :: Relations + , buildConflictsIndep :: Relations + , binaryPackages :: [BinaryDebDescription] -- This should perhaps be a set, or a map + } deriving (Eq, Ord, Show, Data, Typeable) + +newSourceDebDescription :: SourceDebDescription +newSourceDebDescription = + SourceDebDescription + { source = Nothing + , maintainer = Nothing + , changedBy = Nothing + , uploaders = [] + , dmUploadAllowed = False + , priority = Nothing + , section = Nothing + , buildDepends = [] + , buildConflicts = [] + , buildDependsIndep = [] + , buildConflictsIndep = [] + , standardsVersion = Nothing + , homepage = Nothing + , vcsFields = Set.empty + , xFields = Set.empty + , binaryPackages = [] } + +newSourceDebDescription' :: SrcPkgName -> NameAddr -> SourceDebDescription +newSourceDebDescription' src who = + newSourceDebDescription + { source = Just src + , maintainer = Just who } + +data VersionControlSpec + = VCSBrowser Text + | VCSArch Text + | VCSBzr Text + | VCSCvs Text + | VCSDarcs Text + | VCSGit Text + | VCSHg Text + | VCSMtn Text + | VCSSvn Text + deriving (Eq, Ord, Show, Data, Typeable) + +-- | User defined fields. Parse the line "XBS-Comment: I stand +-- between the candle and the star." to get XField (fromList "BS") +-- "Comment" " I stand between the candle and the star." +data XField + = XField (Set XFieldDest) Text Text + deriving (Eq, Ord, Show, Data, Typeable) + +data XFieldDest + = B -- ^ Field will be copied to the binary packgae control files + | S -- ^ Field will be copied to the source packgae control files + | C -- ^ Field will be copied to the upload control (.changes) file + deriving (Eq, Ord, Read, Show, Data, Typeable) + +-- | This type represents a section of the control file other than the +-- first, which in turn represent one of the binary packages or debs +-- produced by this debianization. +data BinaryDebDescription + = BinaryDebDescription + { package :: BinPkgName + -- ^ + , architecture :: PackageArchitectures + -- ^ + , binarySection :: Maybe Section + , binaryPriority :: Maybe PackagePriority + , essential :: Bool + -- ^ + , description :: Text + -- ^ + , relations :: PackageRelations + -- ^ + } deriving (Eq, Ord, Read, Show, Data, Typeable) + +newBinaryDebDescription :: BinPkgName -> PackageArchitectures -> BinaryDebDescription +newBinaryDebDescription name arch = + BinaryDebDescription + { package = name -- mkPkgName base typ + , architecture = arch -- packageArch typ + , binarySection = Nothing + , binaryPriority = Nothing + , essential = False + , description = mempty + , relations = newPackageRelations } + +-- | Modify the description of one of the binary debs without changing +-- the package order. +modifyBinaryDeb :: BinPkgName -> (Maybe BinaryDebDescription -> BinaryDebDescription) -> SourceDebDescription -> SourceDebDescription +modifyBinaryDeb bin f deb = + deb {binaryPackages = bins'} + where + bins' = if any (\ x -> package x == bin) bins + then map g (binaryPackages deb) + else binaryPackages deb ++ [f Nothing] + g x = if package x == bin then f (Just x) else x + bins = binaryPackages deb + +-- ^ Package interrelationship information. +data PackageRelations + = PackageRelations + { depends :: Relations + , recommends :: Relations + , suggests :: Relations + , preDepends :: Relations + , breaks :: Relations + , conflicts :: Relations + , provides :: Relations + , replaces :: Relations + , builtUsing :: Relations + } deriving (Eq, Ord, Read, Show, Data, Typeable) + +newPackageRelations :: PackageRelations +newPackageRelations = + PackageRelations + { depends = [] + , recommends = [] + , suggests = [] + , preDepends = [] + , breaks = [] + , conflicts = [] + , provides = [] + , replaces = [] + , builtUsing = [] } + +-- ^ The different types of binary debs we can produce from a haskell package +data PackageType + = Development -- ^ The libghc-foo-dev package. + | Profiling -- ^ The libghc-foo-prof package. + | Documentation -- ^ The libghc-foo-doc package. + | Exec -- ^ A package related to a particular executable, perhaps + -- but not necessarily a server. + | Utilities -- ^ A package that holds the package's data files + -- and any executables not assigned to other + -- packages. + | Source' -- ^ The source package (not a binary deb actually.) + | Cabal -- ^ This is used to construct the value for + -- DEB_CABAL_PACKAGE in the rules file + deriving (Eq, Show) + +packageArch :: PackageType -> PackageArchitectures +packageArch Development = Any +packageArch Profiling = Any +packageArch Documentation = All +packageArch Utilities = All +packageArch Exec = Any +packageArch Cabal = undefined +packageArch Source' = undefined diff --git a/src/Debian/Debianize/Debianize.hs b/src/Debian/Debianize/Debianize.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Debianize.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} + +-- | Generate a package Debianization from Cabal data and command line +-- options. + +module Debian.Debianize.Debianize + ( cabalDebian + , callDebianize + , runDebianize + , debianize + , debianization + , writeDebianization + , describeDebianization + , compareDebianization + , validateDebianization + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Exception (catch) +import Data.Algorithm.Diff.Context (contextDiff) +import Data.Algorithm.Diff.Pretty (prettyDiff) +import Data.Lens.Lazy (getL, setL, modL) +import Data.List as List (unlines, intercalate, nub) +import Data.Map as Map (lookup, toList, elems) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Set as Set (toList) +import Data.Text as Text (Text, unpack, split) +import Data.Version (Version) +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Debianize.Atoms (Atoms, packageDescription, compat, watch, control, copyright, changelog, comments, + sourcePriority, sourceSection, debAction, validate, dryRun, debVersion, revision, + sourcePackageName, epochMap, extraLibMap) +import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), PackageType(..)) +import Debian.Debianize.Dependencies (debianName) +import Debian.Debianize.Files (toFileMap) +import Debian.Debianize.Finalize (finalizeDebianization) +import Debian.Debianize.Goodies (defaultAtoms, watchAtom) +import Debian.Debianize.Input (inputDebianization, inputCabalization, inputCopyright, inputMaintainer, inputChangeLog) +import Debian.Debianize.Options (options, compileArgs) +import Debian.Debianize.SubstVars (substvars) +import Debian.Debianize.Types (DebAction(..)) +import Debian.Debianize.Utility (withCurrentDirectory, foldEmpty, replaceFile, zipMaps, indent) +import Debian.Policy (PackagePriority(Optional), Section(MainSection), getDebhelperCompatLevel) +import Debian.Relation (SrcPkgName(..), BinPkgName(BinPkgName), Relation(Rel)) +import Debian.Release (parseReleaseName) +import Debian.Version (DebianVersion, parseDebianVersion, buildDebianVersion) +import Debian.Time (getCurrentLocalRFC822Time) +import Distribution.Package (PackageIdentifier(..)) +import qualified Distribution.PackageDescription as Cabal +import Prelude hiding (writeFile, unlines) +import System.Console.GetOpt (usageInfo) +import System.Directory (doesFileExist, Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing) +import System.Environment (getArgs, getEnv, getProgName) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ((), takeDirectory) +import System.IO.Error (catchIOError) +import System.Posix.Env (setEnv) +import System.Process (readProcessWithExitCode) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) + +{- +import Debian.Debianize.ControlFile as Debian (SourceDebDescription(source, binaryPackages), BinaryDebDescription(package)) +import Debian.Debianize.Files (toFileMap) +import Debian.Debianize.Goodies (defaultAtoms) +import Debian.Debianize.Input (inputDebianization) +import Debian.Debianize.Utility (withCurrentDirectory) +import System.Directory (Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing) +import Text.PrettyPrint.ANSI.Leijen (pretty) +-} + +-- | The main function for the cabal-debian executable. +cabalDebian :: IO () +cabalDebian = + compileAllArgs defaultAtoms >>= \ atoms -> + case getL debAction atoms of + SubstVar debType -> substvars atoms debType + Debianize -> debianize "." atoms + Usage -> do + progName <- getProgName + let info = "Usage: " ++ progName ++ " [FLAGS]\n" + putStrLn (usageInfo info options) + +-- | Compile the given arguments into an Atoms value and run the +-- debianize function. This is basically equivalent to @cabal-debian +-- --debianize@, except that the command line arguments come from the +-- function parameter. +callDebianize :: [String] -> IO () +callDebianize args = compileEnvironmentArgs defaultAtoms >>= debianize "." . compileArgs args + +-- | Put an argument list into the @CABALDEBIAN@ environment variable +-- and then run the script in debian/Debianize.hs. If this exists and +-- succeeds the return value is True, it may be assumed that a +-- debianization was created in the debian subdirectory of the current +-- directory. This is used to create customized debianizations that +-- are to sophisticated for the command line argument interface +-- available to the cabal-debian executable. +runDebianize :: [String] -> IO Bool +runDebianize args = + doesFileExist "debian/Debianize.hs" >>= \ exists -> + case exists of + False -> return False + True -> + putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ("debian/Debianize.hs" : args) "" >>= \ result -> + case result of + (ExitSuccess, _, _) -> return True + (code, out, err) -> + error ("runDebianize failed with " ++ show code ++ ":\n stdout: " ++ show out ++"\n stderr: " ++ show err) + +-- | Generate a debianization, and then either validate, describe, or +-- write it out dependeing on the command line arguments. +debianize :: FilePath -> Atoms -> IO () +debianize top atoms = + debianization top atoms >>= \ atoms' -> + if getL validate atoms' + then inputDebianization top >>= \ old -> either error return (validateDebianization old atoms') + else if getL dryRun atoms' + then inputDebianization top >>= \ old -> + putStr . ("Debianization (dry run):\n" ++) $ compareDebianization old atoms' + else writeDebianization top atoms' + +-- | Given an Atoms value, get any additional configuration +-- information from the environment, read the cabal package +-- description and possibly the debian/changelog file, then generate +-- and return the new debianization (along with the data directory +-- computed from the cabal package description.) +debianization :: FilePath -> Atoms -> IO Atoms +debianization top atoms = + do log <- (Just <$> inputChangeLog "debian") `catch` (\ (_ :: IOError) -> return Nothing) + atoms' <- inputCabalization top atoms + date <- getCurrentLocalRFC822Time + maint <- inputMaintainer atoms' >>= maybe (error "Missing value for --maintainer") return + level <- getDebhelperCompatLevel + copyright <- withCurrentDirectory top $ inputCopyright (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ show top) + (getL packageDescription atoms')) + return $ debianization' date copyright maint level log atoms' + +debianization' :: String -- ^ current date + -> Text -- ^ copyright + -> NameAddr -- ^ maintainer + -> Int -- ^ Default standards version + -> Maybe ChangeLog + -> Atoms -- ^ Debianization specification + -> Atoms -- ^ New debianization +debianization' date copyright' maint level log deb = + finalizeDebianization $ + modL compat (maybe (Just level) Just) $ + modL changelog (maybe log Just) $ + setL sourcePriority (Just Optional) $ + setL sourceSection (Just (MainSection "haskell")) $ + setL watch (Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))) $ + setL copyright (Just (Right copyright')) $ + versionInfo maint date $ + addExtraLibDependencies $ + -- Do we want to replace the atoms in the old deb, or add these? + -- Or should we delete even more information from the original, + -- keeping only the changelog? Probably the latter. So this is + -- somewhat wrong. + deb + where + pkgDesc = fromMaybe (error "debianization") $ getL packageDescription deb + +-- | Set the debianization's version info - everything that goes into +-- the new changelog entry, source package name, exact debian version, +-- log comments, maintainer name, revision date. +versionInfo :: NameAddr -> String -> Atoms -> Atoms +versionInfo debianMaintainer date deb = + modL changelog (const (Just newLog)) $ + modL control (\ y -> y { source = Just sourceName, Debian.maintainer = Just debianMaintainer }) deb + where + newLog = + case getL changelog deb of + Nothing -> ChangeLog [newEntry] + Just (ChangeLog oldEntries) -> + case dropWhile (\ entry -> logVersion entry > logVersion newEntry) oldEntries of + -- If the new package version number matches the old, merge the new and existing log entries + entry@(Entry {logVersion = d}) : older | d == logVersion newEntry -> ChangeLog (merge entry newEntry : older) + -- Otherwise prepend the new entry + entries -> ChangeLog (newEntry : entries) + newEntry = Entry { logPackage = show (pretty sourceName) + , logVersion = convertVersion debinfo (pkgVersion pkgId) + , logDists = [parseReleaseName "unstable"] + , logUrgency = "low" + , logComments = List.unlines $ (map ((" * " <>) . List.intercalate "\n " . map unpack)) (fromMaybe [["Debianization generated by cabal-debian"]] (getL comments deb)) + , logWho = show (pretty debianMaintainer) + , logDate = date } + -- Get the source package name, either from the SourcePackageName + -- atom or construct it from the cabal package name. + sourceName :: SrcPkgName + sourceName = maybe (debianName deb Source' pkgId) id (getL sourcePackageName deb) + merge :: ChangeLogEntry -> ChangeLogEntry -> ChangeLogEntry + merge old new = + old { logComments = logComments old ++ logComments new + , logDate = date } + debinfo = maybe (Right (epoch, fromMaybe "" (getL revision deb))) Left (getL debVersion deb) + epoch = Map.lookup (pkgName pkgId) (getL epochMap deb) + pkgId = Cabal.package pkgDesc + pkgDesc = fromMaybe (error "versionInfo: no PackageDescription") $ getL packageDescription deb + +-- | Combine various bits of information to produce the debian version +-- which will be used for the debian package. If the override +-- parameter is provided this exact version will be used, but an error +-- will be thrown if that version is unusably old - i.e. older than +-- the cabal version of the package. Otherwise, the cabal version is +-- combined with the given epoch number and revision string to create +-- a version. +convertVersion :: Either DebianVersion (Maybe Int, String) -> Version -> DebianVersion +convertVersion debinfo cabalVersion = + case debinfo of + Left override | override >= parseDebianVersion (show (pretty cabalVersion)) -> override + Left override -> error ("Version from --deb-version (" ++ show (pretty override) ++ + ") is older than hackage version (" ++ show (pretty cabalVersion) ++ + "), maybe you need to unpin this package?") + Right (debianEpoch, debianRevision) -> + buildDebianVersion debianEpoch + (show (pretty cabalVersion)) + (foldEmpty Nothing Just debianRevision) + +-- | Convert the extraLibs field of the cabal build info into debian +-- binary package names and make them dependendencies of the debian +-- devel package (if there is one.) +addExtraLibDependencies :: Atoms -> Atoms +addExtraLibDependencies deb = + modL control (\ y -> y {binaryPackages = map f (binaryPackages (getL control deb))}) deb + where + f :: BinaryDebDescription -> BinaryDebDescription + f bin + | debianName deb Development (Cabal.package pkgDesc) == Debian.package bin + = bin { relations = g (relations bin) } + f bin = bin + g :: Debian.PackageRelations -> Debian.PackageRelations + g rels = rels { Debian.depends = Debian.depends rels ++ + map anyrel' (concatMap (\ cab -> maybe [BinPkgName ("lib" ++ cab ++ "-dev")] Set.toList (Map.lookup cab (getL extraLibMap deb))) + (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc)) } + pkgDesc = fromMaybe (error "addExtraLibDependencies: no PackageDescription") $ getL packageDescription deb + +anyrel' :: BinPkgName -> [Relation] +anyrel' x = [Rel x Nothing Nothing] + +compileAllArgs :: Atoms -> IO Atoms +compileAllArgs atoms0 = compileEnvironmentArgs atoms0 >>= compileCommandlineArgs + +compileEnvironmentArgs :: Atoms -> IO Atoms +compileEnvironmentArgs atoms0 = (compileArgs <$> (read <$> getEnv "CABALDEBIAN") <*> pure atoms0) `catchIOError` const (return atoms0) + +compileCommandlineArgs :: Atoms -> IO Atoms +compileCommandlineArgs atoms0 = compileArgs <$> getArgs <*> pure atoms0 + +-- | Insert a value for CABALDEBIAN into the environment that the +-- withEnvironment* functions above will find and use. E.g. +-- putEnvironmentFlags ["--dry-run", "--validate"] (debianize defaultFlags) +putEnvironmentArgs :: [String] -> IO () +putEnvironmentArgs fs = setEnv "CABALDEBIAN" (show fs) True + +-- | Write the files of the debianization @d@ to the directory @top@. +writeDebianization :: FilePath -> Atoms -> IO () +writeDebianization top d = + withCurrentDirectory top $ + mapM_ (\ (path, text) -> + createDirectoryIfMissing True (takeDirectory path) >> + replaceFile path (unpack text)) + (Map.toList (toFileMap d)) >> + getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True}) + +describeDebianization :: Atoms -> String +describeDebianization atoms = + concatMap (\ (path, text) -> path ++ ":\n" ++ indent " > " (unpack text)) (Map.toList (toFileMap atoms)) + +-- | Compare the existing debianization in @top@ to the generated one +-- @new@, returning a string describing the differences. +compareDebianization :: Atoms -> Atoms -> String +compareDebianization old new = + concat . Map.elems $ zipMaps doFile (toFileMap old) (toFileMap new) + where + doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String + doFile path (Just _) Nothing = Just (path ++ ": Deleted\n") + doFile path Nothing (Just n) = Just (path ++ ": Created\n" ++ indent " | " (unpack n)) + doFile path (Just o) (Just n) = + if o == n + then Nothing -- Just (path ++ ": Unchanged\n") + else Just (show (prettyDiff ("old" path) ("new" path) (contextDiff 2 (split (== '\n') o) (split (== '\n') n)))) + doFile _path Nothing Nothing = error "Internal error in zipMaps" + +-- | Don't change anything, just make sure the new debianization +-- matches the existing debianization in several particulars - +-- specifically, version number, and source and binary package names. +validateDebianization :: Atoms -> Atoms -> Either String () +validateDebianization old new = + case () of + _ | oldVersion /= newVersion -> Left ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion)) + | oldSource /= newSource -> Left ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource)) + | oldPackages /= newPackages -> Left ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages)) + | True -> Right () + where + oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog old)))) + newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog new)))) + oldSource = source . getL control $ old + newSource = source . getL control $ new + oldPackages = map Debian.package . binaryPackages . getL control $ old + newPackages = map Debian.package . binaryPackages . getL control $ new + unChangeLog :: ChangeLog -> [ChangeLogEntry] + unChangeLog (ChangeLog x) = x diff --git a/src/Debian/Debianize/Dependencies.hs b/src/Debian/Debianize/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Dependencies.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} +{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-} +module Debian.Debianize.Dependencies + ( cabalDependencies -- Debian.Cabal.SubstVars + , selfDependency -- Debian.Debianize.Combinators + , allBuildDepends + , debDeps + , putBuildDeps + , dependencies + , debianName + , debNameFromType + , getRulesHead + , filterMissing + , binaryPackageDeps + , binaryPackageConflicts + ) where + +import Data.Char (isSpace, toLower) +import Data.Function (on) +import Data.Lens.Lazy (getL, modL) +import Data.List as List (nub, minimumBy, isSuffixOf, map) +import Data.Map as Map (Map, lookup, insertWith, empty) +import Data.Maybe (fromMaybe, catMaybes, listToMaybe) +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Text as Text (Text, pack, unlines) +import Data.Version (Version, showVersion) +import Debian.Control +import Debian.Debianize.Atoms (Atoms, packageDescription, rulesHead, compiler, noProfilingLibrary, noDocumentationLibrary, + missingDependencies, versionSplits, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap, + packageInfo, depends, conflicts, control) +import Debian.Debianize.Bundled (ghcBuiltIn) +import Debian.Debianize.ControlFile as Debian (PackageType(..), SourceDebDescription(..)) +import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples) +import Debian.Debianize.Types (PackageInfo(devDeb, profDeb, docDeb), VersionSplits(..), DebType(..)) +import Debian.Orphans () +import qualified Debian.Relation as D +import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(pkgNameFromString)) +import Debian.Version (parseDebianVersion) +import Distribution.Package (PackageName(PackageName), PackageIdentifier(..), Dependency(..)) +import Distribution.PackageDescription as Cabal (PackageDescription(..), allBuildInfo, buildTools, pkgconfigDepends, extraLibs) +import Distribution.Version (VersionRange, anyVersion, foldVersionRange', intersectVersionRanges, unionVersionRanges, + laterVersion, orLaterVersion, earlierVersion, orEarlierVersion, fromVersionIntervals, toVersionIntervals, withinVersion, + isNoVersion, asVersionIntervals) +import Distribution.Version.Invert (invertVersionRange) +import Prelude hiding (unlines) +import System.Exit (ExitCode(ExitSuccess)) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (readProcessWithExitCode) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) + +data Dependency_ + = BuildDepends Dependency + | BuildTools Dependency + | PkgConfigDepends Dependency + | ExtraLibs D.BinPkgName + deriving (Eq, Show) + +-- | In cabal a self dependency probably means the library is needed +-- while building the executables. In debian it would mean that the +-- package needs an earlier version of itself to build, so we use this +-- to filter such dependencies out. +selfDependency :: PackageIdentifier -> Dependency_ -> Bool +selfDependency pkgId (BuildDepends (Dependency name _)) = name == pkgName pkgId +selfDependency _ _ = False + +unboxDependency :: Dependency_ -> Maybe Dependency +unboxDependency (BuildDepends d) = Just d +unboxDependency (BuildTools d) = Just d +unboxDependency (PkgConfigDepends d) = Just d +unboxDependency (ExtraLibs _) = Nothing -- Dependency (PackageName d) anyVersion + +-- Make a list of the debian devel packages corresponding to cabal packages +-- which are build dependencies +debDeps :: DebType -> Atoms -> Control' String -> D.Relations +debDeps debType atoms control = + interdependencies ++ otherdependencies + where + interdependencies = + case debType of + Prof -> maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) (debNameFromType control Dev) + _ -> [] + otherdependencies = + catMaybes (map (\ (Dependency name _) -> + case Map.lookup name (getL packageInfo atoms) of + Just p -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (case debType of + Dev -> devDeb p + Prof -> profDeb p + Doc -> docDeb p) + Nothing -> Nothing) (cabalDependencies atoms)) + +cabalDependencies :: Atoms -> [Dependency] +cabalDependencies atoms = + catMaybes $ map unboxDependency $ allBuildDepends atoms + (Cabal.buildDepends (fromMaybe (error "cabalDependencies") $ getL packageDescription atoms)) + (concatMap buildTools . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) + (concatMap pkgconfigDepends . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) + (concatMap extraLibs . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) + +-- |Debian packages don't have per binary package build dependencies, +-- so we just gather them all up here. +allBuildDepends :: Atoms -> [Dependency] -> [Dependency] -> [Dependency] -> [String] -> [Dependency_] +allBuildDepends atoms buildDepends buildTools pkgconfigDepends extraLibs = + nub $ map BuildDepends buildDepends ++ + map BuildTools buildTools ++ + map PkgConfigDepends pkgconfigDepends ++ + map ExtraLibs (fixDeps extraLibs) + where + fixDeps :: [String] -> [D.BinPkgName] + fixDeps xs = concatMap (\ cab -> maybe [D.BinPkgName ("lib" ++ cab ++ "-dev")] Set.toList (Map.lookup cab (getL extraLibMap atoms))) xs + +putBuildDeps :: Atoms -> Atoms +putBuildDeps deb = + modL control (\ y -> y { Debian.buildDepends = debianBuildDeps deb, buildDependsIndep = debianBuildDepsIndep deb }) deb + +-- The haskell-cdbs package contains the hlibrary.mk file with +-- the rules for building haskell packages. +debianBuildDeps :: Atoms -> D.Relations +debianBuildDeps deb = + filterMissing deb $ + nub $ [[D.Rel (D.BinPkgName "debhelper") (Just (D.GRE (parseDebianVersion ("7.0" :: String)))) Nothing], + [D.Rel (D.BinPkgName "haskell-devscripts") (Just (D.GRE (parseDebianVersion ("0.8" :: String)))) Nothing], + anyrel "cdbs", + anyrel "ghc"] ++ + (map anyrel' (Set.toList (getL buildDeps deb))) ++ + (if getL noProfilingLibrary deb then [] else [anyrel "ghc-prof"]) ++ + cabalDeps (getL packageDescription deb) + where + cabalDeps Nothing = [] + cabalDeps (Just pkgDesc) = + (concat $ map (buildDependencies deb) + $ filter (not . selfDependency (Cabal.package pkgDesc)) + $ allBuildDepends + deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) + (concatMap extraLibs . allBuildInfo $ pkgDesc)) + +debianBuildDepsIndep :: Atoms -> D.Relations +debianBuildDepsIndep deb = + filterMissing deb $ + if getL noDocumentationLibrary deb + then [] + else nub $ [anyrel "ghc-doc"] ++ + (map anyrel' (Set.toList (getL buildDepsIndep deb))) ++ + cabalDeps (getL packageDescription deb) + where + cabalDeps Nothing = [] + cabalDeps (Just pkgDesc) = + (concat . map (docDependencies deb) + $ filter (not . selfDependency (Cabal.package pkgDesc)) + $ allBuildDepends + deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc)) + +-- | 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 :: Atoms -> Dependency_ -> D.Relations +docDependencies atoms (BuildDepends (Dependency name ranges)) = + dependencies atoms Documentation name ranges +docDependencies _ _ = [] + +-- | The Debian build dependencies for a package include the profiling +-- libraries and the documentation packages, used for creating cross +-- references. Also the packages associated with extra libraries. +buildDependencies :: Atoms -> Dependency_ -> D.Relations +buildDependencies atoms (BuildDepends (Dependency name ranges)) = + dependencies atoms Development name ranges ++ + dependencies atoms Profiling name ranges +buildDependencies atoms dep@(ExtraLibs _) = + concat (map dependency $ adapt (getL execMap atoms) dep) +buildDependencies atoms dep = + case unboxDependency dep of + Just (Dependency _name _ranges) -> + concat (map dependency $ adapt (getL execMap atoms) dep) + Nothing -> + [] + +dependency :: D.BinPkgName -> D.Relations +dependency name = [[D.Rel name Nothing Nothing]] + +adapt :: Map.Map String D.BinPkgName -> Dependency_ -> [D.BinPkgName] +adapt execMap (PkgConfigDepends (Dependency (PackageName pkg) _)) = + maybe (aptFile pkg) (: []) (Map.lookup pkg execMap) +adapt execMap (BuildTools (Dependency (PackageName pkg) _)) = + maybe (aptFile pkg) (: []) (Map.lookup pkg execMap) +adapt _flags (ExtraLibs x) = [x] +adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [D.BinPkgName pkg] + +-- There are two reasons this may not work, or may work +-- incorrectly: (1) the build environment may be a different +-- distribution than the parent environment (the environment the +-- autobuilder was run from), so the packages in that +-- environment might have different names, and (2) the package +-- we are looking for may not be installed in the parent +-- environment. +aptFile :: String -> [D.BinPkgName] -- Maybe would probably be more correct +aptFile pkg = + unsafePerformIO $ + do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] "" + return $ case ret of + (ExitSuccess, out, _) -> + case takeWhile (not . isSpace) out of + "" -> error $ "Unable to locate a package containing " ++ pkg ++ ", try using --exec-map " ++ pkg ++ "= or Map.insert " ++ show pkg ++ " (BinPkgName \"\") (execMap flags)" + s -> [D.BinPkgName s] + _ -> [] + +anyrel :: String -> [D.Relation] +anyrel x = anyrel' (D.BinPkgName x) + +anyrel' :: D.BinPkgName -> [D.Relation] +anyrel' x = [D.Rel x Nothing Nothing] + +-- | Turn a cabal dependency into debian dependencies. The result +-- needs to correspond to a single debian package to be installed, +-- so we will return just an OrRelation. +dependencies :: Atoms -> PackageType -> PackageName -> VersionRange -> Relations +dependencies atoms typ name cabalRange = + map doBundled $ convert' (canonical (Or (catMaybes (map convert alts)))) + where + + -- Compute a list of alternative debian dependencies for + -- satisfying a cabal dependency. The only caveat is that + -- we may need to distribute any "and" dependencies implied + -- by a version range over these "or" dependences. + alts :: [(BinPkgName, VersionRange)] + alts = case Map.lookup name (packageSplits (getL versionSplits atoms)) of + -- If there are no splits for this package just return the single dependency for the package + Nothing -> [(mkPkgName name typ, cabalRange')] + -- If there are splits create a list of (debian package name, VersionRange) pairs + Just splits' -> map (\ (n, r) -> (mkPkgName n typ, r)) (packageRangesFromVersionSplits splits') + + convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation) + convert (dname, range) = + if isNoVersion range''' + then Nothing + else Just $ + foldVersionRange' + (Rel (D.Rel dname Nothing Nothing)) + (\ v -> Rel (D.Rel dname (Just (D.EEQ (dv v))) Nothing)) + (\ v -> Rel (D.Rel dname (Just (D.SGR (dv v))) Nothing)) + (\ v -> Rel (D.Rel dname (Just (D.SLT (dv v))) Nothing)) + (\ v -> Rel (D.Rel dname (Just (D.GRE (dv v))) Nothing)) + (\ v -> Rel (D.Rel dname (Just (D.LTE (dv v))) Nothing)) + (\ x y -> And [Rel (D.Rel dname (Just (D.GRE (dv x))) Nothing), Rel (D.Rel dname (Just (D.SLT (dv y))) Nothing)]) + (\ x y -> Or [x, y]) + (\ x y -> And [x, y]) + id + range''' + where + -- Choose the simpler of the two + range''' = canon (simpler range' range'') + -- Unrestrict the range for versions that we know don't exist for this debian package + range'' = canon (unionVersionRanges range' (invertVersionRange range)) + -- Restrict the range to the versions specified for this debian package + range' = intersectVersionRanges cabalRange' range + -- When we see a cabal equals dependency we need to turn it into + -- a wildcard because the resulting debian version numbers have + -- various suffixes added. + cabalRange' = + foldVersionRange' + anyVersion + withinVersion -- <- Here we are turning equals into wildcard + laterVersion + earlierVersion + orLaterVersion + orEarlierVersion + (\ lb ub -> intersectVersionRanges (orLaterVersion lb) (earlierVersion ub)) + unionVersionRanges + intersectVersionRanges + id + cabalRange + -- Convert a cabal version to a debian version, adding an epoch number if requested + dv v = parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (getL epochMap atoms)) ++ showVersion v) + simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2] + -- Simplify a VersionRange + canon = fromVersionIntervals . toVersionIntervals + + -- If a package is bundled with the compiler we make the + -- compiler a substitute for that package. If we were to + -- specify the virtual package (e.g. libghc-base-dev) we would + -- have to make sure not to specify a version number. + doBundled :: [D.Relation] -> [D.Relation] + doBundled rels | ghcBuiltIn (fromMaybe (error "dependencies") $ getL compiler atoms) name = rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing] + doBundled rels = rels + + compilerPackageName Documentation = D.BinPkgName "ghc-doc" + compilerPackageName Profiling = D.BinPkgName "ghc-prof" + compilerPackageName Development = D.BinPkgName "ghc" + compilerPackageName _ = D.BinPkgName "ghc" -- whatevs + +data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel {unRel :: a} deriving Show + +convert' :: Rels a -> [[a]] +convert' = map (map unRel . unOr) . unAnd . canonical + +-- | return and of ors of rel +canonical :: Rels a -> Rels a +canonical (Rel rel) = And [Or [Rel rel]] +canonical (And rels) = And $ concatMap (unAnd . canonical) rels +canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels + +-- | Function that applies the mapping from cabal names to debian +-- names based on version numbers. If a version split happens at v, +-- this will return the ltName if < v, and the geName if the relation +-- is >= v. +debianName :: (PkgName name) => Atoms -> PackageType -> PackageIdentifier -> name +debianName atoms typ pkgDesc = + (\ pname -> mkPkgName pname typ) $ + case filter (\ x -> pname == packageName x) (getL versionSplits atoms) of + [] -> pname + [splits] -> + foldTriples' (\ ltName v geName debName -> + if pname /= packageName splits + then debName + else let split = parseDebianVersion (showVersion v) in + case version of + Nothing -> geName + Just (D.SLT v') | v' <= split -> ltName + -- Otherwise use ltName only when the split is below v' + Just (D.EEQ v') | v' < split -> ltName + Just (D.LTE v') | v' < split -> ltName + Just (D.GRE v') | v' < split -> ltName + Just (D.SGR v') | v' < split -> ltName + _ -> geName) + pname + splits + _ -> error $ "Multiple splits for cabal package " ++ string + where + foldTriples' :: (PackageName -> Version -> PackageName -> PackageName -> PackageName) -> PackageName -> VersionSplits -> PackageName + foldTriples' = foldTriples + -- def = mkPkgName pname typ + pname@(PackageName string) = pkgName pkgDesc + version = (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion pkgDesc))))) + +-- | Given a control file and a DebType, look for the binary deb with +-- the corresponding suffix and return its name. +debNameFromType :: Control' String -> DebType -> Maybe BinPkgName +debNameFromType control debType = + case debType of + Dev -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-dev") debNames) + Prof -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-prof") debNames) + Doc -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-doc") debNames) + where + debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control)))) + +-- | Build a debian package name from a cabal package name and a +-- debian package type. Unfortunately, this does not enforce the +-- correspondence between the PackageType value and the name type, so +-- it can return nonsense like (SrcPkgName "libghc-debian-dev"). +mkPkgName :: PkgName name => PackageName -> PackageType -> name +mkPkgName (PackageName name) typ = + pkgNameFromString $ + case typ of + Documentation -> "libghc-" ++ base ++ "-doc" + Development -> "libghc-" ++ base ++ "-dev" + Profiling -> "libghc-" ++ base ++ "-prof" + Utilities -> "haskell-" ++ base ++ "-utils" + Exec -> base + Source' -> "haskell-" ++ base ++ "" + Cabal -> base + where + base = map (fixChar . toLower) name + -- Underscore is prohibited in debian package names. + fixChar :: Char -> Char + fixChar '_' = '-' + fixChar c = toLower c + +instance Interspersed VersionSplits PackageName Version where + leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance" + leftmost (VersionSplits {oldestPackage = p}) = p + pairs (VersionSplits {splits = xs}) = xs + +packageSplits :: [VersionSplits] -> Map PackageName VersionSplits +packageSplits splits = + foldr (\ splits' mp -> Map.insertWith multipleSplitsError (packageName splits') splits' mp) + Map.empty + splits + where + multipleSplitsError :: VersionSplits -> a -> b + multipleSplitsError (VersionSplits {packageName = PackageName p}) _s2 = + error ("Multiple splits for package " ++ show p) + +packageRangesFromVersionSplits :: VersionSplits -> [(PackageName, VersionRange)] +packageRangesFromVersionSplits splits = + foldInverted (\ older dname newer more -> + (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more) + [] + splits + +{- +-- | Generate the head of the debian/rules file. +cdbsRules :: PackageIdentifier -> Atoms -> Atoms +cdbsRules pkgId deb = + setL rulesHead + (Just . unlines $ + ["#!/usr/bin/make -f", + "", + "DEB_CABAL_PACKAGE = " <> name, + "", + "include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk" ]) + deb + where + -- The name is based on the cabal package, but it may need to be + -- modified to avoid violating Debian rules - no underscores, no + -- capital letters. + name = pack (show (pretty (debianName deb Cabal pkgId :: BinPkgName))) +-} + +getRulesHead :: Atoms -> Text +getRulesHead atoms = + fromMaybe computeRulesHead (getL rulesHead atoms) + where + computeRulesHead = + unlines $ + ["#!/usr/bin/make -f", ""] ++ + maybe [] (\ x -> ["DEB_CABAL_PACKAGE = " <> x, ""]) (fmap name (getL packageDescription atoms)) ++ + ["include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk"] + name pkgDesc = pack (show (pretty (debianName atoms Cabal (Cabal.package pkgDesc) :: BinPkgName))) + +filterMissing :: Atoms -> [[Relation]] -> [[Relation]] +filterMissing atoms rels = + filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name (getL missingDependencies atoms)))) rels) + +binaryPackageDeps :: BinPkgName -> Atoms -> [[Relation]] +binaryPackageDeps b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL depends atoms)) + +binaryPackageConflicts :: BinPkgName -> Atoms -> [[Relation]] +binaryPackageConflicts b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL conflicts atoms)) diff --git a/src/Debian/Debianize/Files.hs b/src/Debian/Debianize/Files.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Files.hs @@ -0,0 +1,199 @@ +-- | Convert a Debianization into a list of files that can then be +-- written out. +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TupleSections #-} +module Debian.Debianize.Files + ( toFileMap + ) where + +import Data.Lens.Lazy (getL) +import Data.List as List (map, unlines) +import Data.Map as Map (Map, toList, fromListWithKey, mapKeys) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Set as Set (toList, member) +import Data.Text as Text (Text, pack, unpack, lines, unlines, strip, null) +import Debian.Control (Control'(Control, unControl), Paragraph'(Paragraph), Field'(Field)) +import Debian.Debianize.Atoms (Atoms, compat, sourceFormat, watch, changelog, control, postInst, postRm, preInst, preRm, + intermediateFiles, install, installDir, installInit, logrotateStanza, link, + rulesHead, rulesFragments, copyright) +import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), + VersionControlSpec(..), XField(..), XFieldDest(..)) +import Debian.Debianize.Dependencies (getRulesHead) +import Debian.Debianize.Utility (showDeps') +import Debian.Relation (Relations, BinPkgName(BinPkgName)) +import Prelude hiding (init, unlines, writeFile) +import System.FilePath (()) +import Text.PrettyPrint.ANSI.Leijen (pretty) + +sourceFormatFiles :: Atoms -> [(FilePath, Text)] +sourceFormatFiles deb = maybe [] (\ x -> [("debian/source/format", pack (show (pretty x)))]) (getL sourceFormat deb) + +watchFile :: Atoms -> [(FilePath, Text)] +watchFile deb = maybe [] (\ x -> [("debian/watch", x)]) (getL watch deb) + +intermediates :: Atoms -> [(FilePath, Text)] +intermediates deb = Set.toList $ getL intermediateFiles deb + +installs :: Atoms -> [(FilePath, Text)] +installs deb = + map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (src, dst) -> src <> " " <> dst) (Set.toList pairs))))) $ + Map.toList $ + mapKeys pathf $ + getL install deb + where + pathf name = "debian" show (pretty name) ++ ".install" + +dirs :: Atoms -> [(FilePath, Text)] +dirs deb = + map (\ (path, dirs) -> (path, pack (List.unlines (Set.toList dirs)))) $ Map.toList $ mapKeys pathf $ getL installDir deb + where + pathf name = "debian" show (pretty name) ++ ".dirs" + +init :: Atoms -> [(FilePath, Text)] +init deb = + Map.toList $ mapKeys pathf $ getL installInit deb + where + pathf name = "debian" show (pretty name) ++ ".init" + +-- FIXME - use a map and insertWith, check for multiple entries +logrotate :: Atoms -> [(FilePath, Text)] +logrotate deb = + map (\ (path, stanzas) -> (path, Text.unlines (Set.toList stanzas))) $ Map.toList $ mapKeys pathf $ getL logrotateStanza deb + where + pathf name = "debian" show (pretty name) ++ ".logrotate" + +-- | Assemble all the links by package and output one file each +links :: Atoms -> [(FilePath, Text)] +links deb = + map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (loc, txt) -> loc ++ " " ++ txt) (Set.toList pairs))))) $ + Map.toList $ + mapKeys pathf $ + getL link deb + where + pathf name = "debian" show (pretty name) ++ ".links" + +postinstFiles :: Atoms -> [(FilePath, Text)] +postinstFiles deb = + Map.toList $ mapKeys pathf $ getL postInst deb + where + pathf (BinPkgName name) = "debian" show (pretty name) ++ ".postinst" + +postrmFiles :: Atoms -> [(FilePath, Text)] +postrmFiles deb = + Map.toList $ mapKeys pathf $ getL postRm deb + where + pathf name = "debian" show (pretty name) ++ ".postrm" + +preinstFiles :: Atoms -> [(FilePath, Text)] +preinstFiles deb = + Map.toList $ mapKeys pathf $ getL preInst deb + where + pathf name = "debian" show (pretty name) ++ ".preinst" + +prermFiles :: Atoms -> [(FilePath, Text)] +prermFiles deb = + Map.toList $ mapKeys pathf $ getL preRm deb + where + pathf name = "debian" show (pretty name) ++ ".prerm" + +-- | Turn the Debianization into a list of files, making sure the text +-- associated with each path is unique. Assumes that +-- finalizeDebianization has already been called. (Yes, I'm +-- considering building one into the other, but it is handy to look at +-- the Debianization produced by finalizeDebianization in the unit +-- tests.) +toFileMap :: Atoms -> Map FilePath Text +toFileMap atoms = + Map.fromListWithKey (\ k a b -> error $ "Multiple values for " ++ k ++ ":\n " ++ show a ++ "\n" ++ show b) $ + [("debian/control", pack (show (pretty (controlFile d)))), + ("debian/changelog", pack (show (pretty (fromMaybe (error "Missing debian/changelog") (getL changelog atoms))))), + ("debian/rules", rules atoms), + ("debian/compat", pack (show (fromMaybe (error "Missing DebCompat atom") $ getL compat atoms) <> "\n")), + ("debian/copyright", either (\ x -> pack (show x) <> "\n") id (fromMaybe (error "No DebCopyright atom") $ getL copyright atoms))] ++ + sourceFormatFiles atoms ++ + watchFile atoms ++ + installs atoms ++ + dirs atoms ++ + init atoms ++ + logrotate atoms ++ + links atoms ++ + postinstFiles atoms ++ + postrmFiles atoms ++ + preinstFiles atoms ++ + prermFiles atoms ++ + intermediates atoms + where d = getL control atoms + +rules :: Atoms -> Text +rules deb = Text.unlines (maybe (getRulesHead deb) id (getL rulesHead deb) : reverse (Set.toList (getL rulesFragments deb))) + +controlFile :: SourceDebDescription -> Control' String +controlFile src = + Control + { unControl = + (Paragraph + ([Field ("Source", " " ++ show (pretty (source src))), + Field ("Maintainer", " " <> show (pretty (maintainer src)))] ++ + lField "Uploaders" (uploaders src) ++ + (case dmUploadAllowed src of True -> [Field ("DM-Upload-Allowed", " yes")]; False -> []) ++ + mField "Priority" (priority src) ++ + mField "Section" (section src) ++ + depField "Build-Depends" (buildDepends src) ++ + depField "Build-Depends-Indep" (buildDependsIndep src) ++ + depField "Build-Conflicts" (buildConflicts src) ++ + depField "Build-Conflicts-Indep" (buildConflictsIndep src) ++ + [Field ("Standards-Version", " " <> show (pretty (standardsVersion src)))] ++ + mField "Homepage" (homepage src) ++ + List.map vcsField (Set.toList (vcsFields src)) ++ + List.map xField (Set.toList (xFields src))) : + List.map binary (binaryPackages src)) + } + where + binary :: BinaryDebDescription -> Paragraph' String + binary bin = + Paragraph + ([Field ("Package", " " ++ show (pretty (package bin))), + Field ("Architecture", " " ++ show (pretty (architecture bin)))] ++ + mField "Section" (binarySection bin) ++ + mField "Priority" (binaryPriority bin) ++ + bField "Essential" (essential bin) ++ + relFields (relations bin) ++ + [Field ("Description", " " ++ unpack (ensureDescription (description bin)))]) + where + ensureDescription t = + case Text.lines t of + [] -> "No description available." + (short : long) | Text.null (strip short) -> Text.unlines ("No short description available" : long) + _ -> t + mField tag = maybe [] (\ x -> [Field (tag, " " <> show (pretty x))]) + bField tag flag = if flag then [Field (tag, " yes")] else [] + lField _ [] = [] + lField tag xs = [Field (tag, " " <> show (pretty xs))] + vcsField (VCSBrowser t) = Field ("Vcs-Browser", " " ++ unpack t) + vcsField (VCSArch t) = Field ("Vcs-Arch", " " ++ unpack t) + vcsField (VCSBzr t) = Field ("Vcs-Bzr", " " ++ unpack t) + vcsField (VCSCvs t) = Field ("Vcs-Cvs", " " ++ unpack t) + vcsField (VCSDarcs t) = Field ("Vcs-Darcs", " " ++ unpack t) + vcsField (VCSGit t) = Field ("Vcs-Git", " " ++ unpack t) + vcsField (VCSHg t) = Field ("Vcs-Hg", " " ++ unpack t) + vcsField (VCSMtn t) = Field ("Vcs-Mtn", " " ++ unpack t) + vcsField (VCSSvn t) = Field ("Vcs-Svn", " " ++ unpack t) + xField (XField dests tag t) = Field (unpack ("X" <> showDests dests <> "-" <> tag), unpack (" " <> t)) + showDests s = if member B s then "B" else "" <> + if member S s then "S" else "" <> + if member C s then "C" else "" + +relFields :: PackageRelations -> [Field' [Char]] +relFields rels = + depField "Depends" (depends rels) ++ + depField "Recommends" (recommends rels) ++ + depField "Suggests" (suggests rels) ++ + depField "Pre-Depends" (preDepends rels) ++ + depField "Breaks" (breaks rels) ++ + depField "Conflicts" (conflicts rels) ++ + depField "Provides" (provides rels) ++ + depField "Replaces" (replaces rels) ++ + depField "Built-Using" (builtUsing rels) + +depField :: [Char] -> Relations -> [Field' [Char]] +depField tag rels = case rels of [] -> []; _ -> [Field (tag, " " ++ showDeps' (tag ++ ":") rels)] diff --git a/src/Debian/Debianize/Finalize.hs b/src/Debian/Debianize/Finalize.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Finalize.hs @@ -0,0 +1,301 @@ +-- | Convert a Debianization into a list of files that can then be +-- written out. +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Debian.Debianize.Finalize + ( finalizeDebianization + ) where + +import Data.ByteString.Lazy.UTF8 (fromString) +import Data.Char (toLower) +import Data.Digest.Pure.MD5 (md5) +import Data.Lens.Lazy (setL, getL, modL) +import Data.List as List (map) +import Data.Map as Map (insertWith, foldWithKey, elems) +import Data.Maybe +import Data.Monoid (mempty, (<>)) +import Data.Set as Set (Set, difference, fromList, null, insert, toList, filter, fold, map, union, singleton) +import Data.Text as Text (pack, unlines, unpack) +import Debian.Debianize.Atoms as Atoms + (Atoms, packageDescription, control, binaryArchitectures, rulesFragments, website, serverInfo, link, + backups, executable, sourcePriority, sourceSection, binaryPriorities, binarySections, description, + install, installTo, installData, installCabalExecTo, noProfilingLibrary, noDocumentationLibrary, + utilsPackageName, extraDevDeps, installData, installCabalExec, file, apacheSite, installDir, buildDir, + dataDir, intermediateFiles) +import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), + newBinaryDebDescription, modifyBinaryDeb, + PackageType(Exec, Development, Profiling, Documentation, Utilities)) +import Debian.Debianize.Dependencies (debianName, binaryPackageDeps, binaryPackageConflicts, putBuildDeps) +import Debian.Debianize.Goodies (describe, siteAtoms, serverAtoms, backupAtoms, execAtoms) +import Debian.Debianize.Types (InstallFile(..)) +import Debian.Policy (PackageArchitectures(Any, All), Section(..)) +import Debian.Relation (Relation(Rel), BinPkgName(BinPkgName)) +import Distribution.Package (PackageName(PackageName), PackageIdentifier(..)) +import qualified Distribution.PackageDescription as Cabal +import Prelude hiding (init, unlines, writeFile, map) +import System.FilePath ((), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName) +import Text.PrettyPrint.ANSI.Leijen (pretty) + +-- | Now that we know the build and data directories, we can expand +-- some atoms into sets of simpler atoms which can eventually be +-- turned into the files of the debianization. The original atoms are +-- not removed from the list because they may contribute to the +-- debianization in other ways, so be careful not to do this twice, +-- this function is not idempotent. (Exported for use in unit tests.) +finalizeDebianization :: Atoms -> Atoms +finalizeDebianization deb0 = + deb''''' + where + -- Fixme - makeUtilsPackage does stuff that needs to go through foldAtomsFinalized + deb' = finalizeAtoms deb0 + deb'' = f deb' + deb''' = makeUtilsPackage $ librarySpecs $ putBuildDeps $ deb'' + deb'''' = finalizeAtoms deb''' + deb''''' = g deb'''' -- Apply tweaks to the debianization + + -- Create the binary packages + f :: Atoms -> Atoms + f atoms = (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL website atoms)) . + (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL serverInfo atoms)) . + (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> modL binaryArchitectures (Map.insertWith (flip const) b Any) . cabalExecBinaryPackage b $ atoms'') atoms' (getL backups atoms)) . + (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL executable atoms)) $ atoms + -- Apply the hints in the atoms to the debianization + g :: Atoms -> Atoms + g atoms = (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {priority = Just x}) atoms') (getL sourcePriority atoms)) . + (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {section = Just x}) atoms') (getL sourceSection atoms)) . + (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {architecture = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryArchitectures atoms)) . + (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binaryPriority = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryPriorities atoms)) . + (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binarySection = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binarySections atoms)) . + (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {Debian.description = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL Atoms.description atoms)) $ atoms + +cabalExecBinaryPackage :: BinPkgName -> Atoms -> Atoms +cabalExecBinaryPackage b deb = + modL control (\ y -> y {binaryPackages = bin : binaryPackages y}) deb + where + bin = BinaryDebDescription + { Debian.package = b + , architecture = Any + , binarySection = Just (MainSection "misc") + , binaryPriority = Nothing + , essential = False + , Debian.description = describe deb Exec (Cabal.package pkgDesc) + , relations = binaryPackageRelations b Exec deb + } + pkgDesc = fromMaybe (error "cabalExecBinaryPackage: no PackageDescription") $ getL packageDescription deb + +binaryPackageRelations :: BinPkgName -> PackageType -> Atoms -> PackageRelations +binaryPackageRelations b typ deb = + PackageRelations + { Debian.depends = [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++ + (if typ == Development then List.map anyrel' (toList (getL extraDevDeps deb)) else []) ++ + binaryPackageDeps b deb + , recommends = [anyrel "${haskell:Recommends}"] + , suggests = [anyrel "${haskell:Suggests}"] + , preDepends = [] + , breaks = [] + , conflicts = [anyrel "${haskell:Conflicts}"] ++ binaryPackageConflicts b deb + , provides = [anyrel "${haskell:Provides}"] + , replaces = [] + , builtUsing = [] + } + +-- debLibProf haddock binaryPackageDeps extraDevDeps extraLibMap +librarySpecs :: Atoms -> Atoms +librarySpecs deb | isNothing (getL packageDescription deb) = deb +librarySpecs deb = + (if doc + then modL link (Map.insertWith Set.union debName (singleton ("/usr/share/doc" show (pretty debName) "html" cabal <.> "txt", "/usr/lib/ghc-doc/hoogle" hoogle <.> "txt"))) + else id) $ + modL control + (\ y -> y { binaryPackages = + (if dev then [librarySpec deb Any Development (Cabal.package pkgDesc)] else []) ++ + (if prof then [librarySpec deb Any Profiling (Cabal.package pkgDesc)] else []) ++ + (if doc then [docSpecsParagraph deb (Cabal.package pkgDesc)] else []) ++ + (binaryPackages y) }) + deb + where + doc = dev && not (getL noDocumentationLibrary deb) + prof = dev && not (getL noProfilingLibrary deb) + dev = isJust (Cabal.library pkgDesc) + pkgDesc = fromMaybe (error "librarySpecs: no PackageDescription") $ getL packageDescription deb + PackageName cabal = pkgName (Cabal.package pkgDesc) + debName :: BinPkgName + debName = debianName deb Documentation (Cabal.package pkgDesc) + hoogle = List.map toLower cabal + +docSpecsParagraph :: Atoms -> PackageIdentifier -> BinaryDebDescription +docSpecsParagraph atoms pkgId = + BinaryDebDescription + { Debian.package = debianName atoms Documentation pkgId + , architecture = All + , binarySection = Just (MainSection "doc") + , binaryPriority = Nothing + , essential = False + , Debian.description = describe atoms Documentation pkgId + , relations = binaryPackageRelations (debianName atoms Documentation pkgId) Development atoms + } + +librarySpec :: Atoms -> PackageArchitectures -> PackageType -> PackageIdentifier -> BinaryDebDescription +librarySpec atoms arch typ pkgId = + BinaryDebDescription + { Debian.package = debianName atoms typ pkgId + , architecture = arch + , binarySection = Nothing + , binaryPriority = Nothing + , essential = False + , Debian.description = describe atoms typ pkgId + , relations = binaryPackageRelations (debianName atoms typ pkgId) Development atoms + } + +-- | Create a package to hold any executables and data files not +-- assigned to some other package. +makeUtilsPackage :: Atoms -> Atoms +makeUtilsPackage deb | isNothing (getL packageDescription deb) = deb +makeUtilsPackage deb = + case (Set.difference availableData installedData, Set.difference availableExec installedExec) of + (datas, execs) | Set.null datas && Set.null execs -> deb + (datas, execs) -> + let p = fromMaybe (debianName deb Utilities (Cabal.package pkgDesc)) (getL utilsPackageName deb) + deb' = setL packageDescription (Just pkgDesc) . makeUtilsAtoms p datas execs $ deb in + modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb' + where + f _ _ _ (Just bin) = bin + f deb' p arch Nothing = + let bin = newBinaryDebDescription p arch in + bin {binarySection = Just (MainSection "misc"), + relations = binaryPackageRelations p Utilities deb'} + pkgDesc = fromMaybe (error "makeUtilsPackage: no PackageDescription") $ getL packageDescription deb + availableData = Set.fromList (Cabal.dataFiles pkgDesc) + availableExec = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc))) + installedData :: Set FilePath + installedData = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL install deb) <> + (List.map fst . concat . List.map toList . elems $ getL installTo deb) <> + (List.map fst . concat . List.map toList . elems $ getL installData deb)) + installedExec :: Set String + installedExec = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL installCabalExec deb) <> + (List.map fst . concat . List.map toList . elems $ getL installCabalExecTo deb) <> + (List.map ename . elems $ getL executable deb)) + where ename i = + case sourceDir i of + (Nothing) -> execName i + (Just s) -> s execName i + -- installedExec = foldCabalExecs (Set.insert :: String -> Set String -> Set String) (Set.empty :: Set String) deb + +makeUtilsAtoms :: BinPkgName -> Set FilePath -> Set String -> Atoms -> Atoms +makeUtilsAtoms p datas execs atoms0 = + if Set.null datas && Set.null execs + then atoms0 + else modL rulesFragments (Set.insert (pack ("build" show (pretty p) ++ ":: build-ghc-stamp\n"))) . g $ atoms0 + where + g :: Atoms -> Atoms + g atoms = Set.fold execAtom (Set.fold dataAtom atoms datas) execs + dataAtom path atoms = modL installData (insertWith union p (singleton (path, path))) atoms + execAtom name atoms = modL installCabalExec (insertWith union p (singleton (name, "usr/bin"))) atoms + +anyrel :: String -> [Relation] +anyrel x = anyrel' (BinPkgName x) + +anyrel' :: BinPkgName -> [Relation] +anyrel' x = [Rel x Nothing Nothing] + +finalizeAtoms :: Atoms -> Atoms +finalizeAtoms atoms | atoms == mempty = atoms +finalizeAtoms atoms = atoms <> finalizeAtoms (expandAtoms atoms) + +expandAtoms :: Atoms -> Atoms +expandAtoms old = + expandApacheSite . + expandInstallCabalExec . + expandInstallCabalExecTo . + expandInstallData . + expandInstallTo . + expandFile . + expandWebsite . + expandServer . + expandBackups . + expandExecutable $ + mempty + where + expandApacheSite :: Atoms -> Atoms + expandApacheSite new = + foldWithKey (\ b (dom, log, text) atoms -> + modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom))) . + modL installDir (Map.insertWith Set.union b (singleton log)) . + modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" dom, text))) $ + atoms) + new + (getL apacheSite old) + + expandInstallCabalExec :: Atoms -> Atoms + expandInstallCabalExec new = + foldWithKey (\ b pairs atoms -> Set.fold (\ (name, dst) atoms' -> modL install (Map.insertWith Set.union b (singleton (builddir name name, dst))) atoms') + atoms + pairs) + new + (getL installCabalExec old) + where + builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old) + + expandInstallCabalExecTo :: Atoms -> Atoms + expandInstallCabalExecTo new = + foldWithKey (\ b pairs atoms -> + Set.fold (\ (n, d) atoms' -> + modL rulesFragments (Set.insert (Text.unlines + [ pack ("binary-fixup" show (pretty b)) <> "::" + , "\tinstall -Dp " <> pack (builddir n n) <> " " <> pack ("debian" show (pretty b) makeRelative "/" d) ])) atoms') + atoms + pairs) + new + (getL installCabalExecTo old) + where + builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old) + + expandInstallData :: Atoms -> Atoms + expandInstallData new = + foldWithKey (\ b pairs atoms -> + Set.fold (\ (s, d) atoms' -> + if takeFileName s == takeFileName d + then modL install (Map.insertWith Set.union b (singleton (s, datadir makeRelative "/" (takeDirectory d)))) atoms' + else modL installTo (Map.insertWith Set.union b (singleton (s, datadir makeRelative "/" d))) atoms') + atoms + pairs) + new + (getL installData old) + where + datadir = fromMaybe (error "finalizeAtoms: no dataDir") $ getL dataDir old + + expandInstallTo :: Atoms -> Atoms + expandInstallTo new = + foldWithKey (\ p pairs atoms -> + Set.fold (\ (s, d) atoms' -> + modL rulesFragments (Set.insert (Text.unlines + [ pack ("binary-fixup" show (pretty p)) <> "::" + , "\tinstall -Dp " <> pack s <> " " <> pack ("debian" show (pretty p) makeRelative "/" d) ])) atoms') atoms pairs) + new + (getL installTo old) + + expandFile :: Atoms -> Atoms + expandFile new = + foldWithKey (\ p pairs atoms -> + Set.fold (\ (path, s) atoms' -> + let (destDir', destName') = splitFileName path + tmpDir = "debian/cabalInstall" show (md5 (fromString (unpack s))) + tmpPath = tmpDir destName' in + modL intermediateFiles (Set.insert (tmpPath, s)) . + modL install (Map.insertWith Set.union p (singleton (tmpPath, destDir'))) $ + atoms') + atoms + pairs) + new + (getL file old) + + expandWebsite :: Atoms -> Atoms + expandWebsite new = foldWithKey siteAtoms new (getL website old) + + expandServer :: Atoms -> Atoms + expandServer new = foldWithKey (\ b x atoms -> serverAtoms b x False atoms) new (getL serverInfo old) + + expandBackups :: Atoms -> Atoms + expandBackups new = foldWithKey backupAtoms new (getL backups old) + + expandExecutable :: Atoms -> Atoms + expandExecutable new = foldWithKey execAtoms new (getL executable old) diff --git a/src/Debian/Debianize/Generic.hs b/src/Debian/Debianize/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Generic.hs @@ -0,0 +1,108 @@ +-- | Some generic operations with specializations to avoid broken Data +-- instances in types like Text and Set. +{-# LANGUAGE DeriveDataTypeable, RankNTypes, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Debian.Debianize.Generic + ( geq + , gdiff + , gshow + ) where + +import Prelude hiding (GT) +import Data.Generics (Data, Typeable, GenericQ, toConstr, showConstr, gzipWithQ, extQ, ext1Q, gmapQ, Constr {- , ext2Q, Typeable2, dataTypeName, dataTypeOf-}) +import Data.List (sort) +import qualified Data.Text as T +import Data.Set as Set (Set, toList, fromList, difference) +import Debian.Debianize.Atoms (Atoms) +import Debian.Debianize.ControlFile (VersionControlSpec, XField) +import Debian.Debianize.Utility (showDeps) +import Debian.Relation (Relation) +import Triplets (mkQ2, extQ2) + +-- These instances are only used here, to create debugging messages. +deriving instance Typeable Atoms + +-- deriving instance Data Debianization +-- deriving instance Data DebAtom + +-- ext2Q' :: (Data d, Typeable2 t) => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q +-- ext2Q' = ext2Q + +geq :: GenericQ (GenericQ Bool) +geq x y = + (geq' `mkQ2` stringEq `extQ2` textEq `extQ2` setEq1 `extQ2` setEq2 `extQ2` mapEq1) x y + where + -- If the specialized eqs don't work, use the generic. This + -- will throw an exception if it encounters something with a + -- NoRep type. + geq' :: (Data a, Data b) => a -> b -> Bool + geq' x' y' = (toConstr x' == toConstr y') && and (gzipWithQ geq x' y') + stringEq :: String -> String -> Bool + stringEq a b = (a == b) + textEq :: T.Text -> T.Text -> Bool + textEq a b = (a == b) + setEq1 :: Set VersionControlSpec -> Set VersionControlSpec -> Bool + setEq1 a b = toList a == toList b + setEq2 :: Set XField -> Set XField -> Bool + setEq2 a b = toList a == toList b + mapEq1 :: Atoms -> Atoms -> Bool + mapEq1 a b = (a == b) + +data Diff + = Diff { stack :: [Constr], expected :: String, actual :: String } + | SetDiff { stack :: [Constr], expected :: String, missing :: String, extra :: String } + deriving (Eq, Show) + +gdiff :: GenericQ (GenericQ [Diff]) +gdiff x y = + (gdiff' `mkQ2` stringEq `extQ2` textEq `extQ2` setEq1 `extQ2` setEq2 `extQ2` mapEq1 `extQ2` relEq) x y + where + -- If the specialized eqs don't work, use the generic. This + -- will throw an exception if it encounters something with a + -- NoRep type. + gdiff' :: (Data a, Data b) => a -> b -> [Diff] + gdiff' x' y' = + if toConstr x' == toConstr y' + then map (\ diff -> diff {stack = toConstr x' : stack diff}) (concat (gzipWithQ gdiff x' y')) + else [Diff {stack = [], expected = gshow x', actual = gshow y'}] + stringEq :: String -> String -> [Diff] + stringEq a b = if (a == b) then [] else [Diff {stack = [], expected = show a, actual = show b}] + textEq :: T.Text -> T.Text -> [Diff] + textEq a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}] + setEq1 :: Set VersionControlSpec -> Set VersionControlSpec -> [Diff] + setEq1 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}] + setEq2 :: Set XField -> Set XField -> [Diff] + setEq2 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}] + mapEq1 :: Atoms -> Atoms -> [Diff] + mapEq1 a b = if a == b then [] else [Diff {stack = [], expected = show a, actual = show b}] + relEq :: [[Relation]] -> [[Relation]] -> [Diff] + relEq a b = if Set.fromList a == Set.fromList b + then [] + else [SetDiff {stack = [], + expected = show [a, b], + missing = showDeps (sort (Set.toList (Set.difference (Set.fromList a) (Set.fromList b)))), + extra = showDeps (sort (Set.toList (Set.difference (Set.fromList b) (Set.fromList a))))}] + +{- +gshow' :: Data a => a -> String +gshow' x = + (gshow `extQ` (show :: T.Text -> String) `extQ` (show :: Maybe T.Text -> String)) x +-} + +-- | Generic show: an alternative to \"deriving Show\" +gshow :: Data a => a -> String +gshow x = gshows x "" + +-- | Generic shows +gshows :: Data a => a -> ShowS + +-- This is a prefix-show using surrounding "(" and ")", +-- where we recurse into subterms with gmapQ. +gshows = ( \t -> + showChar '(' + . (showString . showConstr . toConstr $ t) + . (foldr (.) id . gmapQ ((showChar ' ' .) . gshows) $ t) + . showChar ')' + ) `extQ` (shows :: String -> ShowS) + `extQ` ((shows . T.unpack) :: T.Text -> ShowS) + `ext1Q` (\ s -> gshows (toList s)) diff --git a/src/Debian/Debianize/Goodies.hs b/src/Debian/Debianize/Goodies.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Goodies.hs @@ -0,0 +1,376 @@ +-- | Things that seem like they could be clients of this library, but +-- are instead included as part of the library. +{-# LANGUAGE OverloadedStrings #-} +module Debian.Debianize.Goodies + ( defaultAtoms + , tightDependencyFixup + , doServer + , doWebsite + , doBackups + , doExecutable + , debianDescription + , describe + , watchAtom + , oldClckwrksSiteFlags + , oldClckwrksServerFlags + , siteAtoms + , serverAtoms + , backupAtoms + , execAtoms + ) where + +import Data.Lens.Lazy (getL, setL, modL) +import Data.List as List (map, intersperse, intercalate) +import Data.Map as Map (Map, fromList, insertWith) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, (<>)) +import Data.Set as Set (insert, union, singleton) +import Data.Text as Text (Text, pack, unlines, intercalate) +import Data.Version (Version(Version)) +import Debian.Debianize.Atoms as Atoms () +import Debian.Debianize.Atoms as Atoms + (Atoms, packageDescription, rulesFragments, website, serverInfo, link, backups, executable, + install, installTo, installCabalExecTo, file, installDir, logrotateStanza, postInst, + installInit, installCabalExec, rulesFragments, packageDescription, executable, + serverInfo, website, backups, depends, epochMap, versionSplits) +import Debian.Debianize.ControlFile as Debian (PackageType(..)) +import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), VersionSplits(..)) +import Debian.Debianize.Utility (trim) +import Debian.Orphans () +import Debian.Policy (apacheLogDirectory, apacheErrorLog, apacheAccessLog, databaseDirectory, serverAppLog, serverAccessLog) +import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel)) +import Distribution.Package (PackageIdentifier(..), PackageName(PackageName)) +import qualified Distribution.PackageDescription as Cabal +import Distribution.Text (display) +import Prelude hiding (writeFile, init, unlines, log, map) +import System.FilePath (()) +import System.Process (showCommandForUser) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) + +-- | This may not look like a goodie, but it incorporates knowledge +-- about the debian repository - what the epoch number of HaXml is, +-- the fact that the debian package name of parsec changed, etc. +defaultAtoms :: Atoms +defaultAtoms = + setL epochMap knownEpochMappings $ + setL versionSplits knownVersionSplits $ + mempty + +-- | These are the instances of debian names changing that I know +-- about. I know they really shouldn't be hard coded. Send a patch. +-- Note that this inherits the lack of type safety of the mkPkgName +-- function. +knownVersionSplits :: [VersionSplits] +knownVersionSplits = + [ VersionSplits { + packageName = PackageName "parsec" + , oldestPackage = PackageName "parsec2" + , splits = [(Version [3] [], PackageName "parsec3")] } + , VersionSplits { + packageName = PackageName "QuickCheck" + , oldestPackage = PackageName "quickcheck1" + , splits = [(Version [2] [], PackageName "quickcheck2")] } + ] + +-- | We should always call this, just as we should always apply +-- knownVersionSplits. +knownEpochMappings :: Map PackageName Int +knownEpochMappings = + Map.fromList [(PackageName "HaXml", 1)] + +-- | Create equals dependencies. For each pair (A, B), use dpkg-query +-- to find out B's version number, version B. Then write a rule into +-- P's .substvar that makes P require that that exact version of A, +-- and another that makes P conflict with any older version of A. +tightDependencyFixup :: [(BinPkgName, BinPkgName)] -> BinPkgName -> Atoms -> Atoms +tightDependencyFixup [] _ deb = deb +tightDependencyFixup pairs p deb = + modL rulesFragments + (Set.insert + (Text.unlines $ + ([ "binary-fixup/" <> name <> "::" + , "\techo -n 'haskell:Depends=' >> debian/" <> name <> ".substvars" ] ++ + intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map equals pairs) ++ + [ "\techo '' >> debian/" <> name <> ".substvars" + , "\techo -n 'haskell:Conflicts=' >> debian/" <> name <> ".substvars" ] ++ + intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map newer pairs) ++ + [ "\techo '' >> debian/" <> name <> ".substvars" ]))) deb + where + equals (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (=$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars" + newer (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (>>$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars" + name = display' p + display' = pack . show . pretty + +-- | Add a debian binary package to the debianization containing a cabal executable file. +doExecutable :: BinPkgName -> InstallFile -> Atoms -> Atoms +doExecutable bin x deb = modL executable (Map.insertWith (error "executable") bin x) deb + +-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a server. +doServer :: BinPkgName -> Server -> Atoms -> Atoms +doServer bin x deb = modL serverInfo (Map.insertWith (error "serverInfo") bin x) deb + +-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a web site. +doWebsite :: BinPkgName -> Site -> Atoms -> Atoms +doWebsite bin x deb = modL website (Map.insertWith (error "website") bin x) deb + +-- | Add a debian binary package to the debianization containing a cabal executable file set up to be a backup script. +doBackups :: BinPkgName -> String -> Atoms -> Atoms +doBackups bin s deb = + modL backups (Map.insertWith (error "backups") bin s) $ + modL Atoms.depends (Map.insertWith union bin (singleton (Rel (BinPkgName "anacron") Nothing Nothing))) $ + deb + +describe :: Atoms -> PackageType -> PackageIdentifier -> Text +describe atoms typ ident = + debianDescription (Cabal.synopsis pkgDesc) (Cabal.description pkgDesc) (Cabal.author pkgDesc) (Cabal.maintainer pkgDesc) (Cabal.pkgUrl pkgDesc) typ ident + where + pkgDesc = fromMaybe (error $ "describe " ++ show ident) $ getL packageDescription atoms + +debianDescription :: String -> String -> String -> String -> String -> PackageType -> PackageIdentifier -> Text +debianDescription synopsis' description' author' maintainer' url typ pkgId = + debianDescriptionBase synopsis' description' author' maintainer' url <> "\n" <> + case typ of + Profiling -> + Text.intercalate "\n" + [" .", + " This package provides a library for the Haskell programming language, compiled", + " for profiling. See http:///www.haskell.org/ for more information on Haskell."] + Development -> + Text.intercalate "\n" + [" .", + " This package provides a library for the Haskell programming language.", + " See http:///www.haskell.org/ for more information on Haskell."] + Documentation -> + Text.intercalate "\n" + [" .", + " This package provides the documentation for a library for the Haskell", + " programming language.", + " See http:///www.haskell.org/ for more information on Haskell." ] + Exec -> + Text.intercalate "\n" + [" .", + " An executable built from the " <> pack (display (pkgName pkgId)) <> " package."] +{- ServerPackage -> + Text.intercalate "\n" + [" .", + " A server built from the " <> pack (display (pkgName pkgId)) <> " package."] -} + Utilities -> + Text.intercalate "\n" + [" .", + " Utility files associated with the " <> pack (display (pkgName pkgId)) <> " package."] + x -> error $ "Unexpected library package name suffix: " ++ show x + +-- | The Cabal package has one synopsis and one description field +-- for the entire package, while in a Debian package there is a +-- description field (of which the first line is synopsis) in +-- each binary package. So the cabal description forms the base +-- of the debian description, each of which is amended. +debianDescriptionBase :: String -> String -> String -> String -> String -> Text +debianDescriptionBase synopsis' description' author' maintainer' url = + (pack . unwords . words $ synopsis') <> + case description' of + "" -> "" + text -> + let text' = text ++ "\n" ++ + list "" ("\n Author: " ++) author' ++ + list "" ("\n Upstream-Maintainer: " ++) maintainer' ++ + list "" ("\n Url: " ++) url in + "\n " <> (pack . trim . List.intercalate "\n " . List.map addDot . lines $ text') + where + addDot line = if all (flip elem " \t") line then "." else line + list :: b -> ([a] -> b) -> [a] -> b + list d f l = case l of [] -> d; _ -> f l + +oldClckwrksSiteFlags :: Site -> [String] +oldClckwrksSiteFlags x = + [ -- According to the happstack-server documentation this needs a trailing slash. + "--base-uri", "http://" ++ domain x ++ "/" + , "--http-port", show port] +oldClckwrksServerFlags :: Server -> [String] +oldClckwrksServerFlags x = + [ -- According to the happstack-server documentation this needs a trailing slash. + "--base-uri", "http://" ++ hostname x ++ ":" ++ show (port x) ++ "/" + , "--http-port", show port] + +watchAtom :: PackageName -> Text +watchAtom (PackageName pkgname) = + pack $ "version=3\nopts=\"downloadurlmangle=s|archive/([\\w\\d_-]+)/([\\d\\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\\\nfilenamemangle=s|(.*)/$|" ++ pkgname ++ + "-$1.tar.gz|\" \\\n http://hackage.haskell.org/packages/archive/" ++ pkgname ++ + " \\\n ([\\d\\.]*\\d)/\n" + +siteAtoms :: BinPkgName -> Site -> Atoms -> Atoms +siteAtoms b site = + modL installDir (Map.insertWith Set.union b (singleton "/etc/apache2/sites-available")) . + modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ domain site, "/etc/apache2/sites-enabled/" ++ domain site))) . + modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" domain site, apacheConfig))) . + modL installDir (Map.insertWith Set.union b (singleton (apacheLogDirectory b))) . + modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $ + [ pack (apacheAccessLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}"]))) . + modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $ + [ pack (apacheErrorLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}" ]))) . + serverAtoms b (server site) True + where + -- An apache site configuration file. This is installed via a line + -- in debianFiles. + apacheConfig = + Text.unlines $ + [ "" + , " ServerAdmin " <> pack (serverAdmin site) + , " ServerName www." <> pack (domain site) + , " ServerAlias " <> pack (domain site) + , "" + , " ErrorLog " <> pack (apacheErrorLog b) + , " CustomLog " <> pack (apacheAccessLog b) <> " combined" + , "" + , " ProxyRequests Off" + , " AllowEncodedSlashes NoDecode" + , "" + , " " + , " AddDefaultCharset off" + , " Order deny,allow" + , " #Allow from .example.com" + , " Deny from all" + , " #Allow from all" + , " " + , "" + , " port' <> "/*>" + , " AddDefaultCharset off" + , " Order deny,allow" + , " #Allow from .example.com" + , " #Deny from all" + , " Allow from all" + , " " + , "" + , " SetEnv proxy-sendcl 1" + , "" + , " ProxyPass / http://127.0.0.1:" <> port' <> "/ nocanon" + , " ProxyPassReverse / http://127.0.0.1:" <> port' <> "/" + , "" ] + port' = pack (show (port (server site))) + +serverAtoms :: BinPkgName -> Server -> Bool -> Atoms -> Atoms +serverAtoms b server isSite = + modL postInst (insertWith (error "serverAtoms") b debianPostinst) . + modL installInit (Map.insertWith (error "serverAtoms") b debianInit) . + serverLogrotate' b . + execAtoms b exec + where + exec = installFile server + debianInit = + Text.unlines $ + [ "#! /bin/sh -e" + , "" + , ". /lib/lsb/init-functions" + , "" + , "case \"$1\" in" + , " start)" + , " test -x /usr/bin/" <> pack (destName exec) <> " || exit 0" + , " log_begin_msg \"Starting " <> pack (destName exec) <> "...\"" + , " mkdir -p " <> pack (databaseDirectory b) + , " " <> startCommand + , " log_end_msg $?" + , " ;;" + , " stop)" + , " log_begin_msg \"Stopping " <> pack (destName exec) <> "...\"" + , " " <> stopCommand + , " log_end_msg $?" + , " ;;" + , " *)" + , " log_success_msg \"Usage: ${0} {start|stop}\"" + , " exit 1" + , "esac" + , "" + , "exit 0" ] + startCommand = pack $ showCommandForUser "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverOptions) + stopCommand = pack $ showCommandForUser "start-stop-daemon" (stopOptions ++ commonOptions) + commonOptions = ["--pidfile", "/var/run/" ++ destName exec] + startOptions = ["--start", "-b", "--make-pidfile", "-d", databaseDirectory b, "--exec", "/usr/bin" destName exec] + stopOptions = ["--stop", "--oknodo"] ++ if retry server /= "" then ["--retry=" ++ retry server ] else [] + serverOptions = serverFlags server ++ commonServerOptions + -- Without these, happstack servers chew up CPU even when idle + commonServerOptions = ["+RTS", "-IO", "-RTS"] + + debianPostinst = + Text.unlines $ + ([ "#!/bin/sh" + , "" + , "case \"$1\" in" + , " configure)" ] ++ + (if isSite + then [ " # Apache won't start if this directory doesn't exist" + , " mkdir -p " <> pack (apacheLogDirectory b) + , " # Restart apache so it sees the new file in /etc/apache2/sites-enabled" + , " /usr/sbin/a2enmod proxy" + , " /usr/sbin/a2enmod proxy_http" + , " service apache2 restart" ] + else []) ++ + [ " service " <> pack (show (pretty b)) <> " start" + , " ;;" + , "esac" + , "" + , "#DEBHELPER#" + , "" + , "exit 0" ]) + +-- | A configuration file for the logrotate facility, installed via a line +-- in debianFiles. +serverLogrotate' :: BinPkgName -> Atoms -> Atoms +serverLogrotate' b = + modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}" ]))) . + modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}" ]))) + +backupAtoms :: BinPkgName -> String -> Atoms -> Atoms +backupAtoms b name = + modL postInst (insertWith (error "backupAtoms") b + (Text.unlines $ + [ "#!/bin/sh" + , "" + , "case \"$1\" in" + , " configure)" + , " " <> pack ("/etc/cron.hourly" name) <> " --initialize" + , " ;;" + , "esac" ])) . + execAtoms b (InstallFile { execName = name + , destName = name + , sourceDir = Nothing + , destDir = Just "/etc/cron.hourly" }) + +execAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms +execAtoms b ifile r = + modL rulesFragments (Set.insert (pack ("build" show (pretty b) ++ ":: build-ghc-stamp"))) . + fileAtoms b ifile $ + r + +fileAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms +fileAtoms b installFile r = + fileAtoms' b (sourceDir installFile) (execName installFile) (destDir installFile) (destName installFile) r + +fileAtoms' :: BinPkgName -> Maybe FilePath -> String -> Maybe FilePath -> String -> Atoms -> Atoms +fileAtoms' b sourceDir execName destDir destName r = + case (sourceDir, execName == destName) of + (Nothing, True) -> modL installCabalExec (insertWith Set.union b (singleton (execName, d))) r + (Just s, True) -> modL install (insertWith Set.union b (singleton (s execName, d))) r + (Nothing, False) -> modL installCabalExecTo (insertWith Set.union b (singleton (execName, (d destName)))) r + (Just s, False) -> modL installTo (insertWith Set.union b (singleton (s execName, d destName))) r + where + d = fromMaybe "usr/bin" destDir diff --git a/src/Debian/Debianize/Input.hs b/src/Debian/Debianize/Input.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Input.hs @@ -0,0 +1,315 @@ +-- | Read an existing Debianization from a directory file. +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Debian.Debianize.Input + ( inputDebianization + , inputChangeLog + , inputCabalization + , inputCopyright + , inputMaintainer + ) where + +import Debug.Trace (trace) + +import Control.Exception (SomeException, catch, bracket) +import Control.Monad (when, foldM, filterM) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Char (isSpace) +import Data.Lens.Lazy (getL, setL, modL) +import Data.Map as Map (insertWith) +import Data.Maybe (fromMaybe, fromJust) +import Data.Monoid (mempty) +import Data.Set as Set (toList, fromList, insert, union, singleton) +import Data.Text (Text, unpack, pack, lines, words, break, strip, null) +import Data.Text.IO (readFile) +import Debian.Changes (ChangeLog(..), parseChangeLog) +import Debian.Control (Control'(unControl), Paragraph'(..), stripWS, parseControlFromFile, Field, Field'(..), ControlFunctions) +import Debian.Debianize.Atoms as Atoms + (Atoms, rulesHead, compat, sourceFormat, watch, changelog, control, copyright, + intermediateFiles, postInst, postRm, preInst, preRm, install, installDir, warning, + logrotateStanza, installInit, link, packageDescription, compiler, maintainer, verbosity, + compilerVersion, cabalFlagAssignments) +import Debian.Debianize.ControlFile (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), + VersionControlSpec(..), XField(..), newSourceDebDescription', newBinaryDebDescription) +import Debian.Debianize.Utility (getDirectoryContents', readFile', withCurrentDirectory) +import Debian.Orphans () +import Debian.Policy (Section(..), parseStandardsVersion, readPriority, readSection, parsePackageArchitectures, parseMaintainer, + parseUploaders, readSourceFormat, getDebianMaintainer, haskellMaintainer) +import Debian.Relation (Relations, BinPkgName(..), SrcPkgName(..), parseRelations) +import Distribution.License (License(..)) +import Distribution.Package (Package(packageId)) +import Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, license, maintainer)) +import Distribution.PackageDescription.Configuration (finalizePackageDescription) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..), Compiler(..)) +import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Simple.Utils (defaultPackageDesc, die, setupMessage) +import Distribution.System (Platform(..), buildOS, buildArch) +import Distribution.Verbosity (Verbosity, intToVerbosity) +import Prelude hiding (readFile, lines, words, break, null, log, sum) +import System.Cmd (system) +import System.Directory (doesFileExist) +import System.Exit (ExitCode(..)) +import System.FilePath ((), takeExtension, dropExtension) +import System.Posix.Files (setFileCreationMask) +import System.IO.Error (catchIOError) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) + +inputDebianization :: FilePath -> IO Atoms +inputDebianization top = + do (ctl, _) <- inputSourceDebDescription debian `catchIOError` (\ e -> error ("Failure parsing SourceDebDescription: " ++ show e)) + -- Different from snd of above? + atoms <- inputAtomsFromDirectory debian mempty `catch` (\ (e :: SomeException) -> error ("Failure parsing atoms: " ++ show e)) + return $ modL control (const ctl) atoms + where + debian = top "debian" + +inputSourceDebDescription :: FilePath -> IO (SourceDebDescription, [Field]) +inputSourceDebDescription debian = + do paras <- parseControlFromFile (debian "control") >>= either (error . show) (return . unControl) + case paras of + [] -> error "Missing source paragraph" + [_] -> error "Missing binary paragraph" + (hd : tl) -> return $ parseSourceDebDescription hd tl + +parseSourceDebDescription :: Paragraph' String -> [Paragraph' String] -> (SourceDebDescription, [Field]) +parseSourceDebDescription (Paragraph fields) binaryParagraphs = + foldr readField (src, []) fields' + where + fields' = map stripField fields + src = (newSourceDebDescription' findSource findMaint) {binaryPackages = bins} + findSource = findMap "Source" SrcPkgName fields' + findMaint = findMap "Maintainer" (either error id . parseMaintainer) fields' + -- findStandards = findMap "Standards-Version" parseStandardsVersion fields' + + (bins, _extra) = unzip $ map parseBinaryDebDescription binaryParagraphs + readField :: Field -> (SourceDebDescription, [Field]) -> (SourceDebDescription, [Field]) + -- Mandatory + readField (Field ("Source", _)) x = x + readField (Field ("Maintainer", _)) x = x + -- readField (Field ("Standards-Version", _)) x = x + -- Recommended + readField (Field ("Standards-Version", value)) (desc, unrecognized) = (desc {standardsVersion = Just (parseStandardsVersion value)}, unrecognized) + readField (Field ("Priority", value)) (desc, unrecognized) = (desc {priority = Just (readPriority value)}, unrecognized) + readField (Field ("Section", value)) (desc, unrecognized) = (desc {section = Just (MainSection value)}, unrecognized) + -- Optional + readField (Field ("Homepage", value)) (desc, unrecognized) = (desc {homepage = Just (strip (pack value))}, unrecognized) + readField (Field ("Uploaders", value)) (desc, unrecognized) = (desc {uploaders = either (const []) id (parseUploaders value)}, unrecognized) + readField (Field ("DM-Upload-Allowed", value)) (desc, unrecognized) = (desc {dmUploadAllowed = yes value}, unrecognized) + readField (Field ("Build-Depends", value)) (desc, unrecognized) = (desc {buildDepends = rels value}, unrecognized) + readField (Field ("Build-Conflicts", value)) (desc, unrecognized) = (desc {buildConflicts = rels value}, unrecognized) + readField (Field ("Build-Depends-Indep", value)) (desc, unrecognized) = (desc {buildDependsIndep = rels value}, unrecognized) + readField (Field ("Build-Conflicts-Indep", value)) (desc, unrecognized) = (desc {buildConflictsIndep = rels value}, unrecognized) + readField (Field ("Vcs-Browser", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBrowser (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Arch", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSArch (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Bzr", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBzr (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Cvs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSCvs (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Darcs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSDarcs (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Git", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSGit (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Hg", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSHg (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Mtn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSMtn (pack s)) (vcsFields desc)}, unrecognized) + readField (Field ("Vcs-Svn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSSvn (pack s)) (vcsFields desc)}, unrecognized) + readField field@(Field ('X' : fld, value)) (desc, unrecognized) = + case span (`elem` "BCS") fld of + (xs, '-' : more) -> (desc {xFields = insert (XField (fromList (map (read' . (: [])) xs)) (pack more) (pack value)) (xFields desc)}, unrecognized) + _ -> (desc, field : unrecognized) + readField field (desc, unrecognized) = (desc, field : unrecognized) + +parseBinaryDebDescription :: Paragraph' String -> (BinaryDebDescription, [Field]) +parseBinaryDebDescription (Paragraph fields) = + foldr readField (bin, []) fields' + where + fields' = map stripField fields + bin = newBinaryDebDescription findPackage findArchitecture + findPackage = findMap "Package" BinPkgName fields' + findArchitecture = findMap "Architecture" parsePackageArchitectures fields' +{- +(BinPkgName (fromJust (fieldValue "Package" bin))) +(read' (fromJust (fieldValue "Architecture" bin))) +, [] + foldr readField (newBinaryDebDescription (BinPkgName (fromJust (fieldValue "Package" bin))) (read' (fromJust (fieldValue "Architecture" bin))), []) (map stripField fields) +-} + + readField :: Field -> (BinaryDebDescription, [Field]) -> (BinaryDebDescription, [Field]) + readField (Field ("Package", value)) (desc, unrecognized) = (desc {package = BinPkgName value}, unrecognized) + readField (Field ("Architecture", value)) (desc, unrecognized) = (desc {architecture = parsePackageArchitectures value}, unrecognized) + readField (Field ("Section", value)) (desc, unrecognized) = (desc {binarySection = Just (readSection value)}, unrecognized) + readField (Field ("Priority", value)) (desc, unrecognized) = (desc {binaryPriority = Just (readPriority value)}, unrecognized) + readField (Field ("Essential", value)) (desc, unrecognized) = (desc {essential = yes value}, unrecognized) + readField (Field ("Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {depends = rels value}}, unrecognized) + readField (Field ("Recommends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {recommends = rels value}}, unrecognized) + readField (Field ("Suggests", value)) (desc, unrecognized) = (desc {relations = (relations desc) {suggests = rels value}}, unrecognized) + readField (Field ("Pre-Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {preDepends = rels value}}, unrecognized) + readField (Field ("Breaks", value)) (desc, unrecognized) = (desc {relations = (relations desc) {breaks = rels value}}, unrecognized) + readField (Field ("Conflicts", value)) (desc, unrecognized) = (desc {relations = (relations desc) {conflicts = rels value}}, unrecognized) + readField (Field ("Provides", value)) (desc, unrecognized) = (desc {relations = (relations desc) {provides = rels value}}, unrecognized) + readField (Field ("Replaces", value)) (desc, unrecognized) = (desc {relations = (relations desc) {replaces = rels value}}, unrecognized) + readField (Field ("Built-Using", value)) (desc, unrecognized) = (desc {relations = (relations desc) {builtUsing = rels value}}, unrecognized) + readField (Field ("Description", value)) (desc, unrecognized) = (desc {description = pack value}, unrecognized) + readField field (desc, unrecognized) = (desc, field : unrecognized) + +-- | Look for a field and apply a function to its value +findMap :: String -> (String -> a) -> [Field] -> a +findMap field f fields = + fromMaybe (error $ "Missing field: " ++ field) (foldr findMap' Nothing fields) + where + findMap' (Field (fld, val)) x = if fld == field then Just (f val) else x + findMap' _ x = x + +read' :: Read a => String -> a +read' s = trace ("read " ++ show s) (read s) + +stripField :: ControlFunctions a => Field' a -> Field' a +stripField (Field (a, b)) = Field (a, stripWS b) +stripField x = x + +rels :: String -> Relations +rels s = + either (\ e -> error ("Relations field error: " ++ show e ++ "\n " ++ s)) id (parseRelations s) + +yes :: String -> Bool +yes "yes" = True +yes "no" = False +yes x = error $ "Expecting yes or no: " ++ x + +inputChangeLog :: FilePath -> IO ChangeLog +inputChangeLog debian = readFile (debian "changelog") >>= return . parseChangeLog . unpack -- `catch` handleDoesNotExist :: IO ChangeLog + +inputAtomsFromDirectory :: FilePath -> Atoms -> IO Atoms -- .install files, .init files, etc. +inputAtomsFromDirectory debian xs = + findFiles xs >>= doFiles (debian "cabalInstall") + where + findFiles :: Atoms -> IO Atoms + findFiles xs' = + getDirectoryContents' debian >>= + return . (++ ["source/format"]) >>= + filterM (doesFileExist . (debian )) >>= + foldM (\ xs'' name -> inputAtoms debian name xs'') xs' + doFiles :: FilePath -> Atoms -> IO Atoms + doFiles tmp xs' = + do sums <- getDirectoryContents' tmp `catchIOError` (\ _ -> return []) + paths <- mapM (\ sum -> getDirectoryContents' (tmp sum) >>= return . map (sum )) sums >>= return . concat + files <- mapM (readFile . (tmp )) paths + foldM (\ xs'' (path, file) -> return $ modL intermediateFiles (Set.insert ("debian/cabalInstall" path, file)) xs'') xs' (zip paths files) + +inputAtoms :: FilePath -> FilePath -> Atoms -> IO Atoms +inputAtoms _ path xs | elem path ["control"] = return xs +inputAtoms debian name@"source/format" xs = readFile (debian name) >>= \ text -> return $ (either (modL warning . Set.insert) (setL sourceFormat . Just) (readSourceFormat text)) xs +inputAtoms debian name@"watch" xs = readFile (debian name) >>= \ text -> return $ setL watch (Just text) xs +inputAtoms debian name@"rules" xs = readFile (debian name) >>= \ text -> return $ setL rulesHead (Just text) xs +inputAtoms debian name@"compat" xs = readFile (debian name) >>= \ text -> return $ setL compat (Just (read (unpack text))) xs +inputAtoms debian name@"copyright" xs = readFile (debian name) >>= \ text -> return $ setL copyright (Just (Right text)) xs +inputAtoms debian name@"changelog" xs = + readFile (debian name) >>= return . parseChangeLog . unpack >>= \ log -> return $ setL changelog (Just log) xs +inputAtoms debian name xs = + case (BinPkgName (dropExtension name), takeExtension name) of + (p, ".install") -> readFile (debian name) >>= \ text -> return $ foldr (readInstall p) xs (lines text) + (p, ".dirs") -> readFile (debian name) >>= \ text -> return $ foldr (readDir p) xs (lines text) + (p, ".init") -> readFile (debian name) >>= \ text -> return $ modL installInit (insertWith (error "inputAtoms") p text) xs + (p, ".logrotate") -> readFile (debian name) >>= \ text -> return $ modL logrotateStanza (insertWith Set.union p (singleton text)) xs + (p, ".links") -> readFile (debian name) >>= \ text -> return $ foldr (readLink p) xs (lines text) + (p, ".postinst") -> readFile (debian name) >>= \ text -> return $ modL postInst (insertWith (error "inputAtoms") p text) xs + (p, ".postrm") -> readFile (debian name) >>= \ text -> return $ modL postRm (insertWith (error "inputAtoms") p text) xs + (p, ".preinst") -> readFile (debian name) >>= \ text -> return $ modL preInst (insertWith (error "inputAtoms") p text) xs + (p, ".prerm") -> readFile (debian name) >>= \ text -> return $ modL preRm (insertWith (error "inputAtoms") p text) xs + (_, ".log") -> return xs -- Generated by debhelper + (_, ".debhelper") -> return xs -- Generated by debhelper + (_, ".hs") -> return xs -- Code that uses this library + (_, ".setup") -> return xs -- Compiled Setup.hs file + (_, ".substvars") -> return xs -- Unsupported + (_, "") -> return xs -- File with no extension + (_, x) | last x == '~' -> return xs -- backup file + _ -> trace ("Ignored: " ++ debian name) (return xs) + +readLink :: BinPkgName -> Text -> Atoms -> Atoms +readLink p line atoms = + case words line of + [a, b] -> modL link (insertWith Set.union p (singleton (unpack a, unpack b))) atoms + [] -> atoms + _ -> trace ("readLink: " ++ show line) atoms + +readInstall :: BinPkgName -> Text -> Atoms -> Atoms +readInstall p line atoms = + case break isSpace line of + (_, b) | null b -> error $ "readInstall: syntax error in .install file for " ++ show p ++ ": " ++ show line + (a, b) -> modL install (insertWith union p (singleton (unpack (strip a), unpack (strip b)))) atoms + +readDir :: BinPkgName -> Text -> Atoms -> Atoms +readDir p line atoms = modL installDir (insertWith union p (singleton (unpack line))) atoms + +inputCabalization :: FilePath -> Atoms -> IO Atoms +inputCabalization top atoms = + withCurrentDirectory top $ do + descPath <- defaultPackageDesc vb + genPkgDesc <- readPackageDescription vb descPath + (compiler', _) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration vb + let compiler'' = case getL compilerVersion atoms of + (Just ver) -> compiler' {compilerId = CompilerId GHC ver} + _ -> compiler' + case finalizePackageDescription (toList (getL cabalFlagAssignments atoms)) (const True) (Platform buildArch buildOS) (compilerId compiler'') [] genPkgDesc of + Left e -> error $ "Failed to load cabal package description: " ++ show e + Right (pkgDesc, _) -> do + liftIO $ bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc + return $ setL compiler (Just compiler'') $ + setL packageDescription (Just pkgDesc) $ atoms + where + vb = intToVerbosity' (getL verbosity atoms) + +-- | Run the package's configuration script. +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) + +-- | Try to read the license file specified in the cabal package, +-- otherwise return a text representation of the License field. +inputCopyright :: PackageDescription -> IO Text +inputCopyright pkgDesc = readFile' (licenseFile pkgDesc) `catchIOError` handle + where handle _e = + do -- here <- getCurrentDirectory + -- hPutStrLn stderr ("Error reading " ++ licenseFile pkgDesc ++ " from " ++ here ++ ": " ++ show _e) + return . pack . showLicense . license $ pkgDesc + +-- | Convert from license to RPM-friendly (now Debian-friendly?) +-- description. The strings are taken from TagsCheck.py in the +-- rpmlint distribution. +showLicense :: License -> String +showLicense (Apache _) = "Apache" +showLicense (GPL _) = "GPL" +showLicense (LGPL _) = "LGPL" +showLicense BSD3 = "BSD" +showLicense BSD4 = "BSD-like" +showLicense PublicDomain = "Public Domain" +showLicense AllRightsReserved = "Proprietary" +showLicense OtherLicense = "Non-distributable" +showLicense MIT = "MIT" +showLicense (UnknownLicense _) = "Unknown" + +-- | Try to compute the debian maintainer from the maintainer field of the +-- cabal package, or from the value returned by getDebianMaintainer. +inputMaintainer :: Atoms -> IO (Maybe NameAddr) +inputMaintainer atoms = + debianPackageMaintainer >>= maybe cabalPackageMaintainer (return . Just) >>= + maybe getDebianMaintainer (return . Just) >>= + maybe lastResortMaintainer (return . Just) + where + debianPackageMaintainer :: IO (Maybe NameAddr) + debianPackageMaintainer = return (getL Atoms.maintainer atoms) + cabalPackageMaintainer :: IO (Maybe NameAddr) + cabalPackageMaintainer = return $ case fmap Cabal.maintainer (getL packageDescription atoms) of + Nothing -> Nothing + Just "" -> Nothing + Just x -> either (const Nothing) Just (parseMaintainer (takeWhile (\ c -> c /= ',' && c /= '\n') x)) + lastResortMaintainer :: IO (Maybe NameAddr) + lastResortMaintainer = return (Just haskellMaintainer) + +intToVerbosity' :: Int -> Verbosity +intToVerbosity' n = fromJust (intToVerbosity (max 0 (min 3 n))) diff --git a/src/Debian/Debianize/Interspersed.hs b/src/Debian/Debianize/Interspersed.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Interspersed.hs @@ -0,0 +1,61 @@ +-- | A class used while converting Cabal dependencies into Debian +-- dependencies. + +{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -Werror #-} +module Debian.Debianize.Interspersed + ( Interspersed(..) + ) where + +import Debug.Trace + +-- | A class of Bs insterspersed with Cs. It is used when converting +-- the cabal dependencies to debian, where the "around" type is the +-- binary package name and the "between" type is the version number. +-- +-- Minimum implementation is a method to return the leftmost B, and +-- another to return the following (C,B) pairs. Its unfortunate to +-- require lists in the implementation, a fold function would be +-- better (though I find implementing such folds to be a pain in the +-- you-know-what.) +-- +-- The class provides implementations of three folds, each of which +-- exposes slightly different views of the data. +class Interspersed t around between | t -> around, t -> between where + leftmost :: t -> around + pairs :: t -> [(between, around)] + + foldTriples :: (around -> between -> around -> r -> r) -> r -> t -> r + foldTriples f r0 x = snd $ foldl (\ (b1, r) (c, b2) -> (b2, f b1 c b2 r)) (leftmost x, r0) (pairs x) + + -- Treat the b's as the centers and the c's as the things to their + -- left and right. Use Maybe to make up for the missing c's at the + -- ends. + foldInverted :: (Maybe between -> around -> Maybe between -> r -> r) -> r -> t -> r + foldInverted f r0 x = + (\ (bn, an, r) -> f bn an Nothing r) $ + foldl g (Nothing, leftmost x, r0) (pairs x) + where + g (b1, a1, r) (b2, a2) = (Just b2, a2, f b1 a1 (Just b2) r) + + foldArounds :: (around -> around -> r -> r) -> r -> t -> r + foldArounds f r0 x = snd $ foldl (\ (a1, r) (_, a2) -> (a2, f a1 a2 r)) (leftmost x, r0) (pairs x) + + foldBetweens :: (between -> r -> r) -> r -> t -> r + foldBetweens f r0 x = foldl (\ r (b, _) -> (f b r)) r0 (pairs x) + +-- | An example +data Splits = Splits Double [(String, Double)] deriving Show + +instance Interspersed Splits Double String where + leftmost (Splits x _) = x + pairs (Splits _ x) = x + +_splits :: Splits +_splits = Splits 1.0 [("between 1 and 2", 2.0), ("between 2 and 3", 3.0)] + +_test1 :: () +_test1 = foldTriples (\ l s r () -> trace ("l=" ++ show l ++ " s=" ++ show s ++ " r=" ++ show r) ()) () _splits + +_test2 :: () +_test2 = foldInverted (\ sl f sr () -> trace ("sl=" ++ show sl ++ " f=" ++ show f ++ " sr=" ++ show sr) ()) () _splits diff --git a/src/Debian/Debianize/Options.hs b/src/Debian/Debianize/Options.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Options.hs @@ -0,0 +1,135 @@ +module Debian.Debianize.Options + ( compileArgs + , options + ) where + +import Data.Char (toLower, isDigit, ord) +import Data.Lens.Lazy (setL, modL) +import Data.Map as Map (insertWith) +import Data.Set as Set (fromList, insert, union, singleton) +import Data.Version (parseVersion) +import Debian.Debianize.Atoms -- (Atoms, depends, conflicts) +import Debian.Debianize.Goodies (doExecutable) +import Debian.Debianize.Types (InstallFile(..), DebAction(..)) +import Debian.Orphans () +import Debian.Policy (SourceFormat(Quilt3), parseMaintainer) +import Debian.Relation (BinPkgName(..), SrcPkgName(..), Relation(..)) +import Debian.Version (parseDebianVersion) +import Distribution.PackageDescription (FlagName(..)) +import Distribution.Package (PackageName(..)) +import Prelude hiding (readFile, lines, null, log, sum) +import System.Console.GetOpt (ArgDescr(..), OptDescr(..), ArgOrder(RequireOrder), getOpt') +import System.FilePath ((), splitFileName) +import Text.ParserCombinators.ReadP (readP_to_S) +import Text.Regex.TDFA ((=~)) + +compileArgs :: [String] -> Atoms -> Atoms +compileArgs args atoms = + case getOpt' RequireOrder options args of + (os, [], [], []) -> foldl (flip ($)) atoms os + (_, non, unk, errs) -> error ("Errors: " ++ show errs ++ + ", Unrecognized: " ++ show unk ++ + ", Non-Options: " ++ show non) + +-- | Options that modify other atoms. +options :: [OptDescr (Atoms -> Atoms)] +options = + [ Option "v" ["verbose"] (ReqArg (\ s atoms -> setL verbosity (read s) atoms) "n") + "Change build verbosity", + Option "n" ["dry-run", "compare"] (NoArg (\ atoms -> setL dryRun True atoms)) + "Just compare the existing debianization to the one we would generate.", + Option "h?" ["help"] (NoArg (\ atoms -> setL debAction Usage atoms)) + "Show this help text", + Option "" ["debianize"] (NoArg (\ atoms -> setL debAction Debianize atoms)) + "Generate a new debianization, replacing any existing one. One of --debianize or --substvar is required.", + Option "" ["substvar"] (ReqArg (\ name atoms -> setL debAction (SubstVar (read name)) atoms) "Doc, Prof, or Dev") + (unlines ["Write out the list of dependencies required for the dev, prof or doc package depending", + "on the argument. This value can be added to the appropriate substvars file."]), + Option "" ["executable"] (ReqArg (\ path x -> executableOption path (\ bin e -> doExecutable bin e x)) "SOURCEPATH or SOURCEPATH:DESTDIR") + "Create individual eponymous executable packages for these executables. Other executables and data files are gathered into a single utils package.", + Option "" ["ghc-version"] (ReqArg (\ ver x -> setL compilerVersion (Just (last (map fst (readP_to_S parseVersion ver)))) x) "VERSION") + "Version of GHC in build environment", + Option "" ["disable-haddock"] (NoArg (setL noDocumentationLibrary True)) + "Don't generate API documentation. Use this if build is crashing due to a haddock error.", + Option "" ["missing-dependency"] (ReqArg (\ name atoms -> modL missingDependencies (insert (BinPkgName name)) atoms) "DEB") + "Mark a package missing, do not add it to any dependency lists in the debianization.", + Option "" ["source-package-name"] (ReqArg (\ name x -> setL sourcePackageName (Just (SrcPkgName name)) x) "NAME") + "Use this name for the debian source package. Default is haskell-, where the cabal package name is downcased.", + Option "" ["disable-library-profiling"] (NoArg (setL noProfilingLibrary True)) + "Don't generate profiling libraries", + Option "f" ["flags"] (ReqArg (\ fs atoms -> modL cabalFlagAssignments (union (fromList (flagList fs))) atoms) "FLAGS") + "Set given flags in Cabal conditionals", + Option "" ["maintainer"] (ReqArg (\ maint x -> setL maintainer (either (error ("Invalid maintainer string: " ++ show maint)) Just (parseMaintainer maint)) x) "Maintainer Name ") + "Override the Maintainer name and email in $DEBEMAIL/$EMAIL/$DEBFULLNAME/$FULLNAME", + Option "" ["build-dep"] (ReqArg (\ name atoms -> modL buildDeps (Set.insert (BinPkgName name)) atoms) "Debian binary package name") + "Specify a package to add to the build dependency list for this source package, e.g. '--build-dep libglib2.0-dev'.", + Option "" ["build-dep-indep"] (ReqArg (\ name atoms -> modL buildDepsIndep (Set.insert (BinPkgName name)) atoms) "Debian binary package name") + "Specify a package to add to the architecture independent build dependency list for this source package, e.g. '--build-dep-indep perl'.", + Option "" ["dev-dep"] (ReqArg (\ name atoms -> modL extraDevDeps (Set.insert (BinPkgName name)) atoms) "Debian binary package name") + "Specify a package to add to the Depends: list of the -dev package, e.g. '--dev-dep libncurses5-dev'. It might be good if this implied --build-dep.", + Option "" ["depends"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL depends (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") + "Generalized --dev-dep - specify pairs A:B of debian binary package names, each A gets a Depends: B", + Option "" ["conflicts"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL conflicts (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") + "Specify pairs A:B of debian binary package names, each A gets a Conflicts: B. Note that B can have debian style version relations", + Option "" ["map-dep"] (ReqArg (\ pair atoms -> case break (== '=') pair of + (cab, (_ : deb)) -> modL extraLibMap (Map.insertWith Set.union cab (singleton (b deb))) atoms + (_, "") -> error "usage: --map-dep CABALNAME=DEBIANNAME") "CABALNAME=DEBIANNAME") + "Specify a mapping from the name appearing in the Extra-Library field of the cabal file to a debian binary package name, e.g. --dep-map cryptopp=libcrypto-dev", + Option "" ["deb-version"] (ReqArg (\ version atoms -> setL debVersion (Just (parseDebianVersion version)) atoms) "VERSION") + "Specify the version number for the debian package. This will pin the version and should be considered dangerous.", + Option "" ["revision"] (ReqArg (setL revision . Just) "REVISION") + "Add this string to the cabal version to get the debian version number. By default this is '-1~hackage1'. Debian policy says this must either be empty (--revision '') or begin with a dash.", + Option "" ["epoch-map"] (ReqArg (\ pair atoms -> case break (== '=') pair of + (_, (_ : ['0'])) -> atoms + (cab, (_ : [d])) | isDigit d -> modL epochMap (Map.insertWith (flip const) (PackageName cab) (ord d - ord '0')) atoms + _ -> error "usage: --epoch-map CABALNAME=DIGIT") "CABALNAME=DIGIT") + "Specify a mapping from the cabal package name to a digit to use as the debian package epoch number, e.g. --epoch-map HTTP=1", + Option "" ["exec-map"] (ReqArg (\ s atoms -> case break (== '=') s of + (cab, (_ : deb)) -> modL execMap (Map.insertWith (flip const) cab (b deb)) atoms + _ -> error "usage: --exec-map CABALNAME=DEBNAME") "EXECNAME=DEBIANNAME") + "Specify a mapping from the name appearing in the Build-Tool field of the cabal file to a debian binary package name, e.g. --exec-map trhsx=haskell-hsx-utils", + Option "" ["omit-lt-deps"] (NoArg (setL omitLTDeps True)) + "Don't generate the << dependency when we see a cabal equals dependency.", + Option "" ["quilt"] (NoArg (setL sourceFormat (Just Quilt3))) + "The package has an upstream tarball, write '3.0 (quilt)' into source/format.", + Option "" ["builddir"] (ReqArg (\ s atoms -> setL buildDir (Just (s "build")) atoms) "PATH") + "Subdirectory where cabal does its build, dist/build by default, dist-ghc when run by haskell-devscripts. The build subdirectory is added to match the behavior of the --builddir option in the Setup script." + ] + +anyrel :: BinPkgName -> Relation +anyrel x = Rel x Nothing Nothing + +-- | Process a --executable command line argument +executableOption :: String -> (BinPkgName -> InstallFile -> a) -> a +executableOption arg f = + case span (/= ':') arg of + (sp, md) -> + let (sd, name) = splitFileName sp in + f (BinPkgName name) + (InstallFile { execName = name + , destName = name + , sourceDir = case sd of "./" -> Nothing; _ -> Just sd + , destDir = case md of (':' : dd) -> Just dd; _ -> Nothing }) + +parseDeps :: String -> [(BinPkgName, Relation)] +parseDeps arg = + map pair (split arg) + where + split s = + case s =~ "^[ \t,]*([^,]+)[ \t,]*" :: (String, String, String, [String]) of + (_, _, tl, [hd]) -> hd : split tl + (_, _, "", _) -> [] + _ -> error $ "Invalid dependency: " ++ show s + pair s = + case s =~ "^[ \t:]*([^ \t:]+)[ \t]*:[ \t]*(.+)[ \t]*" :: (String, String, String, [String]) of + (_, _, _, [x, y]) -> (b x, anyrel (b y)) + _ -> error $ "Invalid dependency: " ++ show s + +-- Lifted from Distribution.Simple.Setup, since it's not exported. +flagList :: String -> [(FlagName, Bool)] +flagList = map tagWithValue . words + where tagWithValue ('-':name) = (FlagName (map toLower name), False) + tagWithValue name = (FlagName (map toLower name), True) + +b :: String -> BinPkgName +b = BinPkgName diff --git a/src/Debian/Debianize/SubstVars.hs b/src/Debian/Debianize/SubstVars.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/SubstVars.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections, TypeSynonymInstances #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} + +-- | Support for generating Debianization from Cabal data. + +module Debian.Debianize.SubstVars + ( substvars + ) where + +import Control.Exception (SomeException, try) +import Control.Monad (foldM) +import Control.Monad.Reader (ReaderT(runReaderT)) +import Control.Monad.Trans (lift) +import Data.Lens.Lazy (getL, modL) +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Data.Text (pack) +import Debian.Control +import Debian.Debianize.Atoms (Atoms, compiler, dryRun, packageInfo) +import Debian.Debianize.Dependencies (cabalDependencies, debDeps, debNameFromType, filterMissing) +import Debian.Debianize.Input (inputCabalization) +import Debian.Debianize.Types (PackageInfo(PackageInfo, cabalName, devDeb, profDeb, docDeb), DebType) +import Debian.Debianize.Utility (buildDebVersionMap, DebMap, showDeps, dpkgFileMap, cond, debOfFile, (!), diffFile, replaceFile) +import qualified Debian.Relation as D +import Distribution.Package (Dependency(..), PackageName(PackageName)) +import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) +import Distribution.Simple.Utils (die) +import Distribution.Text (display) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) +import Text.PrettyPrint.ANSI.Leijen (pretty) + +-- | Expand the contents of the .substvars file for a library package. +-- 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 :: Atoms + -> DebType -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc + -> IO () +substvars atoms debType = + do atoms' <- inputCabalization "." atoms + debVersions <- buildDebVersionMap + atoms'' <- libPaths (fromMaybe (error "substvars") $ getL compiler atoms') debVersions atoms' + control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control" + substvars' atoms'' debType control + +substvars' :: Atoms -> DebType -> Control' String -> IO () +substvars' atoms debType control = + 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') -> + readFile path' >>= \ old -> + let new = addDeps old in + diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path')) + (\ diff -> if getL dryRun atoms then putStr diff else replaceFile path' new) + ([], 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 (show . pretty . 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 (filterMissing atoms deps)) : other) + (hdeps, more) -> + case deps of + [] -> unlines (hdeps ++ more) + _ -> unlines (map (++ (", " ++ showDeps (filterMissing atoms deps))) hdeps ++ more) + path = fmap (\ (D.BinPkgName x) -> "debian/" ++ x ++ ".substvars") name + name = debNameFromType control debType + deps = debDeps debType atoms control + -- We must have build dependencies on the profiling and documentation packages + -- of all the cabal packages. + missingBuildDeps = + let requiredDebs = + concat (map (\ (Dependency name _) -> + case Map.lookup name (getL packageInfo atoms) of + Just info -> + let prof = maybe (devDeb info) Just (profDeb info) in + let doc = docDeb info in + catMaybes [prof, doc] + Nothing -> []) (cabalDependencies atoms)) in + filter (not . (`elem` buildDepNames) . fst) requiredDebs + buildDepNames :: [D.BinPkgName] + 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))) + 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 + +libPaths :: Compiler -> DebMap -> Atoms -> IO Atoms +libPaths compiler debVersions atoms + | 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 (foldM (packageInfo' compiler debVersions) atoms (a ++ b)) + | 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 -> Atoms -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO Atoms +packageInfo' compiler debVersions atoms (d, f) = + case parseNameVersion f of + Nothing -> return atoms + Just (p, v) -> lift (doesDirectoryExist (d f cdir)) >>= cond (return atoms) (info (p, v)) + where + parseNameVersion s = + case (break (== '-') (reverse s)) of + (_a, "") -> Nothing + (a, b) -> Just (reverse (tail b), reverse a) + cdir = display (compilerId compiler) + info (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 $ modL packageInfo (Map.insert + (PackageName p) + (PackageInfo { cabalName = PackageName p + , 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 })) atoms diff --git a/src/Debian/Debianize/Tests.hs b/src/Debian/Debianize/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Tests.hs @@ -0,0 +1,611 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Debian.Debianize.Tests + ( tests + ) where + +import Data.Algorithm.Diff.Context (contextDiff) +import Data.Algorithm.Diff.Pretty (prettyDiff) +import Data.Function (on) +import Data.Lens.Lazy (setL, getL, modL) +import Data.List (sortBy) +import Data.Map as Map (differenceWithKey, intersectionWithKey) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (mconcat, (<>), mempty) +import Data.Set as Set (fromList, union, insert, singleton) +import qualified Data.Text as T +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry) +import Debian.Debianize.Debianize (debianization) +import Debian.Debianize.Atoms as Atoms + (Atoms, rulesHead, compat, sourceFormat, changelog, sourcePackageName, control, missingDependencies, revision, + binaryArchitectures, copyright, debVersion, execMap, buildDeps, buildDepsIndep, utilsPackageName, description, + depends, conflicts, install, installData) +import Debian.Debianize.ControlFile as Deb (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..)) +import Debian.Debianize.Debianize (writeDebianization) +import Debian.Debianize.Dependencies (getRulesHead) +import Debian.Debianize.Files (toFileMap) +import Debian.Debianize.Finalize (finalizeDebianization) +import Debian.Debianize.Goodies (defaultAtoms, tightDependencyFixup, doExecutable, doWebsite, doServer, doBackups) +import Debian.Debianize.Input (inputChangeLog, inputDebianization, inputCabalization) +import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..)) +import Debian.Policy (databaseDirectory, StandardsVersion(StandardsVersion), getDebhelperCompatLevel, + getDebianStandardsVersion, PackagePriority(Extra), PackageArchitectures(All), + SourceFormat(Native3), Section(..), parseMaintainer) +import Debian.Relation (Relation(..), VersionReq(..), SrcPkgName(..), BinPkgName(..)) +import Debian.Release (ReleaseName(ReleaseName, relName)) +import Debian.Version (buildDebianVersion, parseDebianVersion) +import Distribution.License (License(BSD3)) +import Prelude hiding (log) +import System.FilePath (()) +import Test.HUnit +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) +import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty, text) + +-- | Create a Debianization based on a changelog entry and a license +-- value. Uses the currently installed versions of debhelper and +-- debian-policy to set the compatibility levels. +newDebianization :: ChangeLog -> Int -> StandardsVersion -> Atoms +newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry" +newDebianization (log@(ChangeLog (entry : _))) level standards = + setL changelog (Just log) $ + setL compat (Just level) $ + modL control (\ x -> x { source = Just (SrcPkgName (logPackage entry)) + , maintainer = (either error Just (parseMaintainer (logWho entry))) + , standardsVersion = Just standards }) $ + defaultAtoms +newDebianization _ _ _ = error "Invalid changelog" + +newDebianization' :: Int -> StandardsVersion -> Atoms +newDebianization' level standards = + setL compat (Just level) $ + modL control (\ x -> x { standardsVersion = Just standards }) $ + defaultAtoms + +tests :: Test +tests = TestLabel "Debianization Tests" (TestList [test1, test2, test3, test4, test5, test6, test7, test8, test9]) + +test1 :: Test +test1 = + TestLabel "test1" $ + TestCase (do level <- getDebhelperCompatLevel + standards <- getDebianStandardsVersion + let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ + newDebianization (ChangeLog [testEntry]) level standards + assertEqual "test1" [] (diffDebianizations testDeb1 deb)) + where + testDeb1 :: Atoms + testDeb1 = + setL rulesHead (Just . T.unlines $ + [ "#!/usr/bin/make -f" + , "" + , "include /usr/share/cdbs/1/rules/debhelper.mk" + , "include /usr/share/cdbs/1/class/hlibrary.mk" ]) $ + setL compat (Just 9) $ -- This will change as new version of debhelper are released + setL copyright (Just (Left BSD3)) $ + modL control + (\ y -> y { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}) + , maintainer = Just (NameAddr (Just "David Fox") "dsf@seereason.com") + , standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)) -- This will change as new versions of debian-policy are released + , buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing], + [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing], + [Rel (BinPkgName "cdbs") Nothing Nothing], + [Rel (BinPkgName "ghc") Nothing Nothing], + [Rel (BinPkgName "ghc-prof") Nothing Nothing]] + , buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]] + }) $ + (newDebianization log 9 (StandardsVersion 3 9 3 (Just 1))) + log = ChangeLog [Entry { logPackage = "haskell-cabal-debian" + , logVersion = buildDebianVersion Nothing "2.6.2" Nothing + , logDists = [ReleaseName {relName = "unstable"}] + , logUrgency = "low" + , logComments = " * Fix a bug constructing the destination pathnames that was dropping\n files that were supposed to be installed into packages.\n" + , logWho = "David Fox " + , logDate = "Thu, 20 Dec 2012 06:49:25 -0800" }] + +test2 :: Test +test2 = + TestLabel "test2" $ + TestCase (do level <- getDebhelperCompatLevel + standards <- getDebianStandardsVersion + let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ newDebianization (ChangeLog [testEntry]) level standards + assertEqual "test2" [] (diffDebianizations expect deb)) + where + expect = + setL rulesHead (Just . T.unlines $ + ["#!/usr/bin/make -f", + "", + "include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk"]) $ + setL compat (Just 9) $ + setL copyright (Just (Left BSD3)) $ + modL control + (\ y -> y + { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}), + maintainer = Just (NameAddr {nameAddr_name = Just "David Fox", nameAddr_addr = "dsf@seereason.com"}), + standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)), + buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing], + [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing], + [Rel (BinPkgName "cdbs") Nothing Nothing], + [Rel (BinPkgName "ghc") Nothing Nothing], + [Rel (BinPkgName "ghc-prof") Nothing Nothing]], + buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]] + }) $ + (newDebianization log 9 (StandardsVersion 3 9 3 (Just 1))) + log = ChangeLog [Entry {logPackage = "haskell-cabal-debian", + logVersion = Debian.Version.parseDebianVersion ("2.6.2" :: String), + logDists = [ReleaseName {relName = "unstable"}], + logUrgency = "low", + logComments = unlines [" * Fix a bug constructing the destination pathnames that was dropping", + " files that were supposed to be installed into packages."], + logWho = "David Fox ", + logDate = "Thu, 20 Dec 2012 06:49:25 -0800"}] + +test3 :: Test +test3 = + TestLabel "test3" $ + TestCase (do deb <- inputDebianization "test-data/haskell-devscripts" + assertEqual "test3" [] (diffDebianizations testDeb2 deb)) + where + testDeb2 :: Atoms + testDeb2 = + setL sourceFormat (Just Native3) $ + setL rulesHead (Just "#!/usr/bin/make -f\n# -*- makefile -*-\n\n# Uncomment this to turn on verbose mode.\n#export DH_VERBOSE=1\n\nDEB_VERSION := $(shell dpkg-parsechangelog | egrep '^Version:' | cut -f 2 -d ' ')\n\nmanpages = $(shell cat debian/manpages)\n\n%.1: %.pod\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n%.1: %\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n.PHONY: build\nbuild: $(manpages)\n\ninstall-stamp:\n\tdh install\n\n.PHONY: install\ninstall: install-stamp\n\nbinary-indep-stamp: install-stamp\n\tdh binary-indep\n\ttouch $@\n\n.PHONY: binary-indep\nbinary-indep: binary-indep-stamp\n\n.PHONY: binary-arch\nbinary-arch: install-stamp\n\n.PHONY: binary\nbinary: binary-indep-stamp\n\n.PHONY: clean\nclean:\n\tdh clean\n\trm -f $(manpages)\n\n\n") $ + setL compat (Just 7) $ + setL copyright (Just (Right "This package was debianized by John Goerzen on\nWed, 6 Oct 2004 09:46:14 -0500.\n\nCopyright information removed from this test data.\n\n")) $ + modL control + (\ y -> y + { source = Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"}) + , maintainer = Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}) + , uploaders = [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}] + , priority = Just Extra + , section = Just (MainSection "haskell") + , buildDepends = (buildDepends y) ++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]] + , buildDependsIndep = (buildDependsIndep y) ++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]] + , standardsVersion = Just (StandardsVersion 3 9 4 Nothing) + , vcsFields = Set.union (vcsFields y) (Set.fromList [ VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts" + , VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"]) + , binaryPackages = [BinaryDebDescription { package = BinPkgName {unBinPkgName = "haskell-devscripts"} + , architecture = All + , binarySection = Nothing + , binaryPriority = Nothing + , essential = False + , Deb.description = + (T.intercalate "\n" + ["Tools to help Debian developers build Haskell packages", + " This package provides a collection of scripts to help build Haskell", + " packages for Debian. Unlike haskell-utils, this package is not", + " expected to be installed on the machines of end users.", + " .", + " This package is designed to support Cabalized Haskell libraries. It", + " is designed to build a library for each supported Debian compiler or", + " interpreter, generate appropriate postinst/prerm files for each one,", + " generate appropriate substvars entries for each one, and install the", + " package in the Debian temporary area as part of the build process."]) + , relations = + PackageRelations + { Deb.depends = + [ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "ghc"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.6" :: String)))) Nothing] + , [Rel (BinPkgName {unBinPkgName = "cdbs"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "${misc:Depends}"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "html-xml-utils"}) Nothing Nothing] + , [Rel (BinPkgName {unBinPkgName = "hscolour"}) (Just (GRE (Debian.Version.parseDebianVersion ("1.8" :: String)))) Nothing] + , [Rel (BinPkgName {unBinPkgName = "ghc-haddock"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.4" :: String)))) Nothing] ] + , recommends = [] + , suggests = [] + , preDepends = [] + , breaks = [] + , Deb.conflicts = [] + , provides = [] + , replaces = [] + , builtUsing = [] }}]}) $ + (newDebianization log 7 (StandardsVersion 3 9 4 Nothing)) + log = ChangeLog [Entry { logPackage = "haskell-devscripts" + , logVersion = Debian.Version.parseDebianVersion ("0.8.13" :: String) + , logDists = [ReleaseName {relName = "experimental"}] + , logUrgency = "low" + , logComments = " [ Joachim Breitner ]\n * Improve parsing of \"Setup register\" output, patch by David Fox\n * Enable creation of hoogle files, thanks to Kiwamu Okabe for the\n suggestion. \n\n [ Kiwamu Okabe ]\n * Need --html option to fix bug that --hoogle option don't output html file.\n * Support to create /usr/lib/ghc-doc/hoogle/*.txt for hoogle package.\n\n [ Joachim Breitner ]\n * Symlink hoogle\8217s txt files to /usr/lib/ghc-doc/hoogle/\n * Bump ghc dependency to 7.6 \n * Bump standards version\n" + , logWho = "Joachim Breitner " + , logDate = "Mon, 08 Oct 2012 21:14:50 +0200" }, + Entry { logPackage = "haskell-devscripts" + , logVersion = Debian.Version.parseDebianVersion ("0.8.12" :: String) + , logDists = [ReleaseName {relName = "unstable"}] + , logUrgency = "low" + , logComments = " * Depend on ghc >= 7.4, adjusting to its haddock --interface-version\n behaviour.\n" + , logWho = "Joachim Breitner " + , logDate = "Sat, 04 Feb 2012 10:50:33 +0100"}] + +test4 :: Test +test4 = + TestLabel "test4" $ + TestCase (do old <- inputDebianization "test-data/clckwrks-dot-com/output" + new <- inputCabalization "test-data/clckwrks-dot-com/input" (newDebianization' 7 (StandardsVersion 3 9 4 Nothing)) >>= + debianization "test-data/clckwrks-dot-com/input" . + (modL control (\ y -> y {homepage = Just "http://www.clckwrks.com/"}) . + setL sourceFormat (Just Native3) . + modL missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) . + setL revision Nothing . + doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production")) . + doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups" . + fixRules . + tight . + setL changelog (getL changelog old)) + assertEqual "test4" [] (diffDebianizations old (copyFirstLogEntry old new))) + where + -- A log entry gets added when the Debianization is generated, + -- it won't match so drop it for the comparison. + serverNames = map BinPkgName ["clckwrks-dot-com-production"] -- , "clckwrks-dot-com-staging", "clckwrks-dot-com-development"] + -- Insert a line just above the debhelper.mk include + fixRules deb = + modL rulesHead (\ mt -> (Just . f) (fromMaybe (getRulesHead deb) mt)) deb + where + f t = T.unlines $ concat $ + map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" + then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text] + else [line] :: [T.Text]) (T.lines t) +{- + mapAtoms f deb + where + f :: DebAtomKey -> DebAtom -> Set (DebAtomKey, DebAtom) + f Source (DebRulesHead t) = + singleton (Source, DebRulesHead (T.unlines $ concat $ + map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" + then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text] + else [line] :: [T.Text]) (T.lines t))) + f k a = singleton (k, a) +-} + tight deb = foldr (tightDependencyFixup + -- For each pair (A, B) make sure that this package requires the + -- same exact version of package B as the version of A currently + -- installed during the build. + [(BinPkgName "libghc-clckwrks-theme-clckwrks-dev", BinPkgName "haskell-clckwrks-theme-clckwrks-utils"), + (BinPkgName "libghc-clckwrks-plugin-media-dev", BinPkgName "haskell-clckwrks-plugin-media-utils"), + (BinPkgName "libghc-clckwrks-plugin-bugs-dev", BinPkgName "haskell-clckwrks-plugin-bugs-utils"), + (BinPkgName "libghc-clckwrks-dev", BinPkgName "haskell-clckwrks-utils")]) deb serverNames + + theSite :: BinPkgName -> Site + theSite deb = + Site { domain = hostname' + , serverAdmin = "logic@seereason.com" + , server = theServer deb } + theServer :: BinPkgName -> Server + theServer deb = + Server { hostname = + case deb of + BinPkgName "clckwrks-dot-com-production" -> hostname' + _ -> hostname' + , port = portNum deb + , headerMessage = "Generated by clckwrks-dot-com/Setup.hs" + , retry = "60" + , serverFlags = + [ "--http-port", show (portNum deb) + , "--hide-port" + , "--hostname", hostname' + , "--top", databaseDirectory deb + , "--enable-analytics" + , "--jquery-path", "/usr/share/javascript/jquery/" + , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" + , "--jstree-path", jstreePath + , "--json2-path",json2Path + ] + , installFile = + InstallFile { execName = "clckwrks-dot-com-server" + , destName = show (pretty deb) + , sourceDir = Nothing + , destDir = Nothing } + } + hostname' = "clckwrks.com" + portNum :: BinPkgName -> Int + portNum (BinPkgName deb) = + case deb of + "clckwrks-dot-com-production" -> 9029 + "clckwrks-dot-com-staging" -> 9038 + "clckwrks-dot-com-development" -> 9039 + _ -> error $ "Unexpected package name: " ++ deb + jstreePath = "/usr/share/clckwrks-0.13.2/jstree" + json2Path = "/usr/share/clckwrks-0.13.2/json2" + +anyrel :: BinPkgName -> Relation +anyrel b = Rel b Nothing Nothing + +test5 :: Test +test5 = + TestLabel "test5" $ + TestCase (do old <- inputDebianization "test-data/creativeprompts/output" + let standards = fromMaybe (error "test5") (standardsVersion (getL control old)) + level = fromMaybe (error "test5") (getL compat old) + new <- debianization "test-data/creativeprompts/input" + (setL sourceFormat (Just Native3) $ + modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-data") All) $ + modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-development") All) $ + modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-production") All) $ + setL utilsPackageName (Just (BinPkgName "creativeprompts-data")) $ + modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-data") + (T.intercalate "\n" [ "creativeprompts.com data files" + , " Static data files for creativeprompts.com"])) $ + modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-production") + (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server" + , " Production version of the blog server, runs on port" + , " 9021 with HTML validation turned off." ])) $ + modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-development") + (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server" + , " Testing version of the blog server, runs on port" + , " 8000 with HTML validation turned on." ])) $ + modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-backups") + (T.intercalate "\n" [ "backup program for creativeprompts.com" + , " Install this somewhere other than creativeprompts.com to run automated" + , " backups of the database."])) $ + modL Atoms.depends (Map.insertWith union (BinPkgName "creativeprompts-server") (singleton (anyrel (BinPkgName "markdown")))) $ + modL execMap (Map.insertWith (error "Conflict in execMap") "trhsx" (BinPkgName "haskell-hsx-utils")) $ + doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups" $ + doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development")) $ + doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production")) $ + setL changelog (getL changelog old) $ + (newDebianization' level standards)) + assertEqual "test5" [] (diffDebianizations old (copyFirstLogEntry old new))) + where + theSite :: BinPkgName -> Site + theSite deb = + Site { domain = hostname' + , serverAdmin = "logic@seereason.com" + , server = theServer deb } + theServer :: BinPkgName -> Server + theServer deb = + Server { hostname = + case deb of + BinPkgName "clckwrks-dot-com-production" -> hostname' + _ -> hostname' + , port = portNum deb + , headerMessage = "Generated by creativeprompts-dot-com/debian/Debianize.hs" + , retry = "60" + , serverFlags = + [ "--http-port", show (portNum deb) + , "--hide-port" + , "--hostname", hostname' + , "--top", databaseDirectory deb + , "--enable-analytics" + , "--jquery-path", "/usr/share/javascript/jquery/" + , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" + , "--jstree-path", jstreePath + , "--json2-path",json2Path + ] + , installFile = + InstallFile { execName = "creativeprompts-server" + , destName = show (pretty deb) + , sourceDir = Nothing + , destDir = Nothing } + } + hostname' = "creativeprompts.com" + portNum :: BinPkgName -> Int + portNum (BinPkgName deb) = + case deb of + "creativeprompts-production" -> 9022 + "creativeprompts-staging" -> 9033 + "creativeprompts-development" -> 9034 + _ -> error $ "Unexpected package name: " ++ deb + jstreePath = "/usr/share/clckwrks-0.13.2/jstree" + json2Path = "/usr/share/clckwrks-0.13.2/json2" + + +copyFirstLogEntry :: Atoms -> Atoms -> Atoms +copyFirstLogEntry deb1 deb2 = + modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2 + where + ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1) + ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2) + +copyChangelog :: Atoms -> Atoms -> Atoms +copyChangelog deb1 deb2 = modL changelog (const (getL changelog deb1)) deb2 + +test6 :: Test +test6 = + TestLabel "test6" $ + TestCase ( do old <- inputDebianization "test-data/artvaluereport2/output" + new <- debianization "test-data/artvaluereport2/input" + (modL control (\ y -> y {homepage = Just "http://appraisalreportonline.com"}) $ + setL sourcePackageName (Just (SrcPkgName "haskell-artvaluereport2")) $ + setL utilsPackageName (Just (BinPkgName "artvaluereport2-server")) $ + modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-development") All) $ + modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-production") All) $ + modL binaryArchitectures (Map.insert (BinPkgName "artvaluereport2-staging") All) $ + modL buildDepsIndep (Set.insert (BinPkgName "libjs-jcrop")) $ + modL buildDepsIndep (Set.insert (BinPkgName "libjs-jquery")) $ + modL buildDepsIndep (Set.insert (BinPkgName "libjs-jquery-u")) $ + + modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-development") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $ + modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-production") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $ + modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-production") (singleton (anyrel (BinPkgName "apache2")))) $ + modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-staging") (singleton (anyrel (BinPkgName "artvaluereport2-server")))) $ + -- This should go into the "real" data directory. And maybe a different icon for each server? + modL install (Map.insertWith union (BinPkgName "artvaluereport2-server") (singleton ("theme/ArtValueReport_SunsetSpectrum.ico", "usr/share/artvaluereport2-data"))) $ + modL Atoms.description (Map.insertWith (error "test6") (BinPkgName "artvaluereport2-backups") + (T.intercalate "\n" + [ "backup program for the appraisalreportonline.com site" + , " Install this somewhere other than where the server is running get" + , " automated backups of the database." ])) $ + doBackups (BinPkgName "artvaluereport2-backups") "artvaluereport2-backups" $ + doWebsite (BinPkgName "artvaluereport2-production") (theSite (BinPkgName "artvaluereport2-production")) $ + doServer (BinPkgName "artvaluereport2-staging") (theServer (BinPkgName "artvaluereport2-staging")) $ + doServer (BinPkgName "artvaluereport2-development") (theServer (BinPkgName "artvaluereport2-development")) $ + flip (foldr (\ s deb -> modL Atoms.depends (Map.insertWith union (BinPkgName "artvaluereport2-server") (singleton (anyrel (BinPkgName s)))) deb)) + ["libjs-jquery", "libjs-jquery-ui", "libjs-jcrop", "libjpeg-progs", "netpbm", + "texlive-latex-recommended", "texlive-latex-extra", "texlive-fonts-recommended", "texlive-fonts-extra"] $ + doExecutable (BinPkgName "artvaluereport2-server") (InstallFile "artvaluereport2-server" Nothing Nothing "artvaluereport2-server") $ + setL changelog (getL changelog old) $ + (newDebianization' 7 (StandardsVersion 3 9 1 Nothing))) + writeDebianization "/tmp" new + assertEqual "test6" [] (diffDebianizations old (copyFirstLogEntry old new))) + where + -- hints = dependencyHints (putExecMap "trhsx" (BinPkgName "haskell-hsx-utils") $ putExtraDevDep (BinPkgName "markdown") $ Flags.defaultFlags) + -- A log entry gets added when the Debianization is generated, + -- it won't match so drop it for the comparison. + -- dropFirstLogEntry (deb@(Debianization {changelog = ChangeLog (_ : tl)})) = deb {changelog = ChangeLog tl} + theSite :: BinPkgName -> Site + theSite deb = + Site { domain = hostname' + , serverAdmin = "logic@seereason.com" + , server = theServer deb } + theServer :: BinPkgName -> Server + theServer deb = + Server { hostname = + case deb of + BinPkgName "artvaluereport2-production" -> hostname' + _ -> hostname' + , port = portNum deb + , headerMessage = "Generated by artvaluereport2/Setup.hs" + , retry = "60" + , serverFlags = + ([ "--http-port", show (portNum deb) + , "--base-uri", case deb of + BinPkgName "artvaluereport2-production" -> "http://" ++ hostname' ++ "/" + _ -> "http://seereason.com:" ++ show (portNum deb) ++ "/" + , "--top", databaseDirectory deb + , "--logs", "/var/log/" ++ show (pretty deb) + , "--log-mode", case deb of + BinPkgName "artvaluereport2-production" -> "Production" + _ -> "Development" + , "--static", "/usr/share/artvaluereport2-data" + , "--no-validate" ] ++ + (case deb of + BinPkgName "artvaluereport2-production" -> [{-"--enable-analytics"-}] + _ -> []) {- ++ + [ "--jquery-path", "/usr/share/javascript/jquery/" + , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" + , "--jstree-path", jstreePath + , "--json2-path",json2Path ] -}) + , installFile = + InstallFile { execName = "artvaluereport2-server" + , destName = show (pretty deb) + , sourceDir = Nothing + , destDir = Nothing } + } + hostname' = "my.appraisalreportonline.com" + portNum :: BinPkgName -> Int + portNum (BinPkgName deb) = + case deb of + "artvaluereport2-production" -> 9027 + "artvaluereport2-staging" -> 9031 + "artvaluereport2-development" -> 9032 + _ -> error $ "Unexpected package name: " ++ deb + +test7 :: Test +test7 = + TestLabel "test7" $ + TestCase ( do old <- inputDebianization "." + new <- debianization "." + (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) $ + setL sourceFormat (Just Native3) $ + setL utilsPackageName (Just (BinPkgName "cabal-debian")) $ + modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (anyrel (BinPkgName "apt-file")))) $ + modL Atoms.conflicts (Map.insertWith union (BinPkgName "cabal-debian") + (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) $ + modL Atoms.description (Map.insertWith (error "test7") (BinPkgName "cabal-debian") + (T.intercalate "\n" + [ "Create a debianization for a cabal package" + , " Tool for creating debianizations of Haskell packages based on the .cabal" + , " file. If apt-file is installed it will use it to discover what is the" + , " debian package name of a C library." + , " ." + , " Author: David Fox " + , " Upstream-Maintainer: David Fox " ])) $ + copyChangelog old $ + newDebianization' 7 (StandardsVersion 3 9 3 Nothing)) + assertEqual "test7" [] (diffDebianizations old (copyChangelog old new))) + +test8 :: Test +test8 = + TestLabel "test8" $ + TestCase ( do old <- inputDebianization "test-data/artvaluereport-data/output" + log <- inputChangeLog "test-data/artvaluereport-data/input/debian" + new <- debianization "test-data/artvaluereport-data/input" + (modL buildDeps (Set.insert (BinPkgName "haskell-hsx-utils")) $ + modL control (\ y -> y {homepage = Just "http://artvaluereportonline.com"}) $ + setL sourceFormat (Just Native3) $ + setL changelog (Just log) $ + (newDebianization' 7 (StandardsVersion 3 9 3 Nothing))) + assertEqual "test8" [] (diffDebianizations old (copyChangelog old new)) + ) + +test9 :: Test +test9 = + TestLabel "test9" $ + TestCase ( do old <- inputDebianization "test-data/alex/output" + new <- debianization "test-data/alex/input" + (modL buildDeps (Set.insert (BinPkgName "alex")) $ + doExecutable (BinPkgName "alex") (InstallFile {execName = "alex", destName = "alex", sourceDir = Nothing, destDir = Nothing}) $ + setL debVersion (Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))) $ + setL sourceFormat (Just Native3) $ + modL control (\ y -> y {homepage = Just "http://www.haskell.org/alex/"}) $ + (\ atoms -> foldr (\ name atoms -> modL installData (Map.insertWith union (BinPkgName "alex") (singleton (name, name))) atoms) + atoms + [ "AlexTemplate" + , "AlexTemplate-debug" + , "AlexTemplate-ghc" + , "AlexTemplate-ghc-debug" + , "AlexWrapper-basic" + , "AlexWrapper-basic-bytestring" + , "AlexWrapper-gscan" + , "AlexWrapper-monad" + , "AlexWrapper-monad-bytestring" + , "AlexWrapper-monadUserState" + , "AlexWrapper-monadUserState-bytestring" + , "AlexWrapper-posn" + , "AlexWrapper-posn-bytestring" + , "AlexWrapper-strict-bytestring"]) $ + newDebianization' 7 (StandardsVersion 3 9 3 Nothing)) + assertEqual "test9" [] (diffDebianizations old (copyFirstLogEntry old new))) + +data Change k a + = Created k a + | Deleted k a + | Modified k a a + | Unchanged k a + deriving (Eq, Show) + +diffMaps :: (Ord k, Eq a, Show k, Show a) => Map.Map k a -> Map.Map k a -> [Change k a] +diffMaps old new = + Map.elems (intersectionWithKey combine1 old new) ++ + map (uncurry Deleted) (Map.toList (differenceWithKey combine2 old new)) ++ + map (uncurry Created) (Map.toList (differenceWithKey combine2 new old)) + where + combine1 k a b = if a == b then Unchanged k a else Modified k a b + combine2 _ _ _ = Nothing + +diffDebianizations :: Atoms -> Atoms -> String -- [Change FilePath T.Text] +diffDebianizations old new = + show (mconcat (map prettyChange (filter (not . isUnchanged) (diffMaps old' new')))) + where + old' = toFileMap (sortBinaryDebs old) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ old)) + new' = toFileMap (sortBinaryDebs new) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ new)) + isUnchanged (Unchanged _ _) = True + isUnchanged _ = False + prettyChange (Unchanged p _) = text ("Unchanged: " <> p <> "\n") + prettyChange (Deleted p _) = text ("Deleted: " <> p <> "\n") + prettyChange (Created p b) = + text ("Created: " <> p <> "\n") <> + prettyDiff ("old" p) ("new" p) + -- We use split here instead of lines so we can + -- detect whether the file has a final newline + -- character. + (contextDiff 2 mempty (T.split (== '\n') b)) + prettyChange (Modified p a b) = + text ("Modified: " <> p<> "\n") <> + prettyDiff ("old" p) ("new" p) + -- We use split here instead of lines so we can + -- detect whether the file has a final newline + -- character. + (contextDiff 2 (T.split (== '\n') a) (T.split (== '\n') b)) + sortBinaryDebs atoms = modL control (\ deb -> deb {binaryPackages = sortBy (compare `on` package) (binaryPackages deb)}) atoms + +testEntry :: ChangeLogEntry +testEntry = + either (error "Error in test changelog entry") fst + (parseEntry (unlines [ "haskell-cabal-debian (2.6.2) unstable; urgency=low" + , "" + , " * Fix a bug constructing the destination pathnames that was dropping" + , " files that were supposed to be installed into packages." + , "" + , " -- David Fox Thu, 20 Dec 2012 06:49:25 -0800" ])) diff --git a/src/Debian/Debianize/Types.hs b/src/Debian/Debianize/Types.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Types.hs @@ -0,0 +1,66 @@ +module Debian.Debianize.Types + ( PackageInfo(..) + , Site(..) + , Server(..) + , InstallFile(..) + , VersionSplits(..) + , DebType(..) + , DebAction(..) + ) where + +import Data.Version (Version) +import Debian.Orphans () +import Debian.Relation (BinPkgName) +import Debian.Version (DebianVersion) +import Distribution.Package (PackageName) +import Prelude hiding (init, unlines, log) + +data PackageInfo = PackageInfo { cabalName :: PackageName + , devDeb :: Maybe (BinPkgName, DebianVersion) + , profDeb :: Maybe (BinPkgName, DebianVersion) + , docDeb :: Maybe (BinPkgName, DebianVersion) } deriving (Eq, Ord, Show) + +-- | Information about the web site we are packaging. +data Site + = Site + { domain :: String -- ^ The domain name assigned to the server. + -- An apache configuration will be generated to + -- redirect requests from this domain to hostname:port + , serverAdmin :: String -- ^ Apache ServerAdmin parameter + , server :: Server -- ^ The hint to install the server job + } deriving (Read, Show, Eq, Ord) + +-- | Information about the server we are packaging. +data Server + = Server + { hostname :: String -- ^ Host on which the server will run + , port :: Int -- ^ Port on which the server will run. + -- Obviously, this must assign each and + -- every server package to a different + -- port. + , headerMessage :: String -- ^ A comment that will be inserted to + -- explain how the file was generated + , retry :: String -- ^ start-stop-daemon --retry argument + , serverFlags :: [String] -- ^ Extra flags to pass to the server via the init script + , installFile :: InstallFile -- ^ The hint to install the server executable + } deriving (Read, Show, Eq, Ord) + +data InstallFile + = InstallFile + { execName :: String -- ^ The name of the executable file + , sourceDir :: Maybe FilePath -- ^ where to find it, default is dist/build// + , destDir :: Maybe FilePath -- ^ where to put it, default is usr/bin/ + , destName :: String -- ^ name to give installed executable + } deriving (Read, Show, Eq, Ord) + +data VersionSplits + = VersionSplits { + packageName :: PackageName + , oldestPackage :: PackageName + , splits :: [(Version, PackageName)] -- Assumed to be in version number order + } deriving (Eq, Ord, Show) + +data DebAction = Usage | Debianize | SubstVar DebType deriving (Read, Show, Eq, Ord) + +-- | A redundant data type, too lazy to expunge. +data DebType = Dev | Prof | Doc deriving (Eq, Ord, Read, Show) diff --git a/src/Debian/Debianize/Utility.hs b/src/Debian/Debianize/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Utility.hs @@ -0,0 +1,231 @@ +-- | Functions used by but not related to cabal-debian, these could +-- conceivably be moved into more general libraries. +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Debian.Debianize.Utility + ( DebMap + , buildDebVersionMap + , (!) + , trim + , strictReadF + , replaceFile + , modifyFile + , diffFile + , removeIfExists + , dpkgFileMap + , cond + , debOfFile + , readFile' + , showDeps + , showDeps' + , withCurrentDirectory + , getDirectoryContents' + , setMapMaybe + , zipMaps + , foldEmpty + , maybeL + , indent + ) where + +import Control.Exception as E (catch, try, bracket, IOException) +import Control.Monad (when) +import Control.Monad.Reader (ReaderT, ask) +import Data.Char (isSpace) +import Data.List as List (isSuffixOf, intercalate, map, lines) +import Data.Lens.Lazy (Lens, modL) +import Data.Map as Map (Map, foldWithKey, empty, fromList, findWithDefault, insert, map, lookup) +import Data.Maybe (catMaybes, mapMaybe) +import Data.Set (Set, toList) +import qualified Data.Set as Set +import Data.Text as Text (Text, unpack, lines) +import Data.Text.IO (hGetContents) +import Debian.Control (parseControl, lookupP, Field'(Field), unControl, stripWS) +import Debian.Version (DebianVersion, prettyDebianVersion) +import Debian.Version.String (parseDebianVersion) +import qualified Debian.Relation as D +import Prelude hiding (map, lookup) +import System.Directory (doesFileExist, doesDirectoryExist, removeFile, renameFile, removeDirectory, getDirectoryContents, getCurrentDirectory, setCurrentDirectory) +import System.Exit(ExitCode(ExitSuccess, ExitFailure)) +import System.FilePath ((), dropExtension) +import System.IO (IOMode (ReadMode), withFile, openFile, hSetBinaryMode) +import System.IO.Error (isDoesNotExistError) +import System.Process (readProcessWithExitCode, showCommandForUser) +import Text.PrettyPrint.ANSI.Leijen (pretty) + +type DebMap = Map.Map D.BinPkgName (Maybe DebianVersion) + +-- | Read and parse the status file for installed debian packages. +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 (D.BinPkgName (stripWS name), Just (parseDebianVersion (stripWS version)))) + _ -> return Nothing) >>= + return . Map.fromList . catMaybes + +(!) :: DebMap -> D.BinPkgName -> DebianVersion +m ! k = maybe (error ("No version number for " ++ (show . pretty $ k) ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m) + +trim :: String -> String +trim = dropWhile isSpace + +strictReadF :: (Text -> r) -> FilePath -> IO r +strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x)) +-- strictRead = strictReadF id + +-- | Write a file which we might still be reading from in +-- order to compute the text argument. +replaceFile :: FilePath -> String -> IO () +replaceFile path text = + do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) + renameFile path back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) + writeFile path text + where + back = path ++ "~" + +-- | Compute the new file contents from the old. If f returns Nothing +-- do not write. +modifyFile :: FilePath -> (String -> IO (Maybe String)) -> IO () +modifyFile path f = + do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) + try (renameFile path back) >>= + either (\ (e :: IOException) -> if not (isDoesNotExistError e) + then ioError e + else f "" >>= maybe (return ()) (writeFile path)) + (\ () -> readFile back >>= f >>= maybe (return ()) (writeFile path)) + where + back = path ++ "~" + +diffFile :: FilePath -> Text -> IO (Maybe String) +diffFile path text = + readProcessWithExitCode cmd args (unpack text) >>= \ (code, out, _err) -> + case code of + ExitSuccess -> return Nothing + ExitFailure 1 -> return (Just out) + _ -> error (showCommandForUser cmd args {- ++ " < " ++ show text -} ++ " -> " ++ show code) + where + cmd = "diff" + args = ["-ruw", path, "-"] + +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 + +-- |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 D.BinPkgName)) +dpkgFileMap = + do + let fp = "/var/lib/dpkg/info" + names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list") + let paths = List.map (fp ) names + files <- mapM (strictReadF Text.lines) paths + return $ Map.fromList $ zip (List.map dropExtension names) (List.map (Set.fromList . List.map (D.BinPkgName . unpack)) $ files) + +-- |Given a path, return the name of the package that owns it. +debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe D.BinPkgName) +debOfFile path = + do mp <- ask + return $ testPath (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 + +readFile' :: FilePath -> IO Text +readFile' path = + do file <- openFile path ReadMode + hSetBinaryMode file True + hGetContents file + +-- Would like to call pretty instead of D.prettyRelations, but the +-- Pretty instance for [a] doesn't work for us. +showDeps :: [[D.Relation]] -> String +showDeps = show . D.prettyRelations + +-- The extra space after prefix' is here for historical reasons(?) +showDeps' :: [a] -> [[D.Relation]] -> String +showDeps' prefix xss = + intercalate ("\n" ++ prefix' ++ " ") . Prelude.lines . show . D.prettyRelations $ xss + where prefix' = List.map (\ _ -> ' ') prefix + +-- | From Darcs.Utils +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory name m = + E.bracket + (do cwd <- getCurrentDirectory + setCurrentDirectory name + return cwd) + (\oldwd -> setCurrentDirectory oldwd {- `catchall` return () -}) + (const m) + +{- +catchall :: IO a -> IO a -> IO a +a `catchall` b = a `catchNonSignal` (\_ -> b) + +-- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows +-- us to catch anything but a signal. Useful for situations where we want +-- don't want to inhibit ctrl-C. + +catchNonSignal :: IO a -> (E.SomeException -> IO a) -> IO a +catchNonSignal comp handler = catch comp handler' + where handler' se = + case fromException se :: Maybe SignalException of + Nothing -> handler se + Just _ -> E.throw se + +newtype SignalException = SignalException Signal deriving (Show, Typeable) + +instance Exception SignalException where + toException e = SomeException e + fromException (SomeException e) = cast e +-} + +getDirectoryContents' :: FilePath -> IO [FilePath] +getDirectoryContents' dir = + getDirectoryContents dir >>= return . filter (not . dotFile) + where + dotFile "." = True + dotFile ".." = True + dotFile _ = False + +setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b +setMapMaybe p = Set.fromList . mapMaybe p . toList + +zipMaps :: Ord k => (k -> Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b -> Map k c +zipMaps f m n = + foldWithKey h (foldWithKey g empty m) n + where + g k a r = case f k (Just a) (lookup k n) of + Just c -> Map.insert k c r -- Both m and n have entries for k + Nothing -> r -- Only m has an entry for k + h k b r = case lookup k m of + Nothing -> case f k Nothing (Just b) of + Just c -> Map.insert k c r -- Only n has an entry for k + Nothing -> r + Just _ -> r + +foldEmpty :: r -> ([a] -> r) -> [a] -> r +foldEmpty r _ [] = r +foldEmpty _ f l = f l + +-- | If the current value of getL x is Nothing, replace it with f. +maybeL :: Lens a (Maybe b) -> Maybe b -> a -> a +maybeL lens mb x = modL lens (maybe mb Just) x + +indent :: [Char] -> String -> String +indent prefix text = unlines (List.map (prefix ++) (List.lines text)) diff --git a/src/Debian/Orphans.hs b/src/Debian/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Orphans.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Debian.Orphans where + +import Data.Function (on) +import Data.Generics (Data, Typeable) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text, unpack) +import Data.Version (Version(..), showVersion) +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Control (Field'(..)) +import Debian.Relation (Relation(..), VersionReq(..), ArchitectureReq(..), + BinPkgName(..), SrcPkgName(..)) +import Debian.Version (DebianVersion, prettyDebianVersion, parseDebianVersion) +import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) +import Distribution.License (License(..)) +import Distribution.PackageDescription (PackageDescription(package), Executable(..)) +import Distribution.Simple.Compiler (Compiler(..)) +import Distribution.Version (VersionRange(..), foldVersionRange') +import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..)) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) + +deriving instance Typeable Compiler +deriving instance Typeable CompilerId +deriving instance Typeable CompilerFlavor +deriving instance Typeable Language +deriving instance Typeable Extension +deriving instance Typeable KnownExtension + +deriving instance Data Extension +deriving instance Data KnownExtension +deriving instance Data Language +deriving instance Data Compiler +deriving instance Data CompilerId +deriving instance Data CompilerFlavor + +deriving instance Ord Language +deriving instance Ord KnownExtension +deriving instance Ord Extension +deriving instance Eq Compiler +deriving instance Ord Compiler +deriving instance Ord NameAddr +deriving instance Ord License + +instance Ord Executable where + compare = compare `on` exeName + +instance Ord PackageDescription where + compare = compare `on` package + +instance Pretty Text where + pretty = text . unpack + +{- +instance Show (Control' String) where + show _ = "" + +instance Show ChangeLog where + show _ = "" +-} + +deriving instance Read ArchitectureReq +deriving instance Read BinPkgName +deriving instance Read ChangeLog +deriving instance Read ChangeLogEntry +deriving instance Read Relation +deriving instance Read SrcPkgName +deriving instance Read VersionReq + +deriving instance Show ArchitectureReq +deriving instance Show ChangeLog +deriving instance Show ChangeLogEntry +deriving instance Show Relation +deriving instance Show VersionReq + +instance Show DebianVersion where + show v = "(Debian.Version.parseDebianVersion (" ++ show (show (prettyDebianVersion v)) ++ " :: String))" + +instance Read DebianVersion where + readsPrec _ s = + case dropPrefix "Debian.Version.parseDebianVersion " s of + Just s' -> case reads s' :: [(String, String)] of + []-> [] + (v, s'') : _ -> [(parseDebianVersion v, s'')] + Nothing -> [] + +dropPrefix :: String -> String -> Maybe String +dropPrefix p s = if isPrefixOf p s then Just (drop (length p) s) else Nothing + +deriving instance Data ArchitectureReq +deriving instance Data BinPkgName +deriving instance Data ChangeLog +deriving instance Data ChangeLogEntry +-- deriving instance Data NameAddr +deriving instance Data Relation +deriving instance Data SrcPkgName +deriving instance Data VersionReq + +deriving instance Typeable ArchitectureReq +deriving instance Typeable BinPkgName +deriving instance Typeable ChangeLog +deriving instance Typeable ChangeLogEntry +-- deriving instance Typeable NameAddr +deriving instance Typeable Relation +deriving instance Typeable SrcPkgName +deriving instance Typeable VersionReq + +deriving instance Ord ChangeLog +deriving instance Ord ChangeLogEntry + +{- +instance Pretty SrcPkgName where + pretty (SrcPkgName x) = pretty x + +instance Pretty BinPkgName where + pretty (BinPkgName x) = pretty x +-} + +deriving instance Typeable License +deriving instance Data Version +deriving instance Data License + +-- Convert from license to RPM-friendly description. The strings are +-- taken from TagsCheck.py in the rpmlint distribution. +instance Pretty License where + pretty (GPL _) = text "GPL" + pretty (LGPL _) = text "LGPL" + pretty (Apache _) = text "Apache" + pretty BSD3 = text "BSD" + pretty BSD4 = text "BSD-like" + pretty PublicDomain = text "Public Domain" + pretty AllRightsReserved = text "Proprietary" + pretty OtherLicense = text "Non-distributable" + pretty MIT = text "MIT" + pretty (UnknownLicense _) = text "Unknown" + +deriving instance Data NameAddr +deriving instance Typeable NameAddr +deriving instance Read NameAddr + +-- This Pretty instance gives a string used to create a valid +-- changelog entry, it *must* have a name followed by an email address +-- in angle brackets. +instance Pretty NameAddr where + pretty x = text (fromMaybe (nameAddr_addr x) (nameAddr_name x) ++ " <" ++ nameAddr_addr x ++ ">") + -- pretty x = text (maybe (nameAddr_addr x) (\ n -> n ++ " <" ++ nameAddr_addr x ++ ">") (nameAddr_name x)) + +deriving instance Show (Field' String) + +instance Pretty VersionRange where + pretty range = + foldVersionRange' + (text "*") + (\ v -> text "=" <> pretty v) + (\ v -> text ">" <> pretty v) + (\ v -> text "<" <> pretty v) + (\ v -> text ">=" <> pretty v) + (\ v -> text "<=" <> pretty v) + (\ x _ -> text "=" <> pretty x <> text ".*") -- not exactly right + (\ x y -> text "(" <> x <> text " || " <> y <> text ")") + (\ x y -> text "(" <> x <> text " && " <> y <> text ")") + (\ x -> text "(" <> x <> text ")") + range + +instance Pretty Version where + pretty = text . showVersion + +instance Pretty DebianVersion where + pretty = text . show diff --git a/src/Debian/Policy.hs b/src/Debian/Policy.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Policy.hs @@ -0,0 +1,233 @@ +-- | Code pulled out of cabal-debian that straightforwardly implements +-- parts of the Debian policy manual, or other bits of Linux standards. +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module Debian.Policy + ( -- * Paths + databaseDirectory + , apacheLogDirectory + , apacheErrorLog + , apacheAccessLog + , serverLogDirectory + , serverAppLog + , serverAccessLog + -- * Installed packages + , debianPackageVersion + , getDebhelperCompatLevel + , StandardsVersion(..) + , getDebianStandardsVersion + , parseStandardsVersion + -- * Package fields + , SourceFormat(..) + , readSourceFormat + , PackagePriority(..) + , readPriority + , PackageArchitectures(..) + , parsePackageArchitectures + , Section(..) + , readSection + , Area(..) + , parseUploaders + , parseMaintainer + , getDebianMaintainer + , haskellMaintainer + ) where + +import Codec.Binary.UTF8.String (decodeString) +import Control.Arrow (second) +import Control.Monad (mplus) +import Data.Char (toLower, isSpace) +import Data.List (groupBy, intercalate) +import Data.Generics (Data, Typeable) +import Data.Text (Text, pack, unpack, strip) +import Data.Monoid ((<>)) +import Debian.Relation (BinPkgName) +import Debian.Version (DebianVersion, parseDebianVersion, version) +import System.Environment (getEnvironment) +import System.FilePath (()) +import System.Process (readProcess) +import Text.Parsec (parse) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr, address) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text) + +databaseDirectory :: BinPkgName -> String +databaseDirectory x = "/srv" show (pretty x) + +apacheLogDirectory :: BinPkgName -> String +apacheLogDirectory x = "/var/log/apache2/" ++ show (pretty x) + +apacheErrorLog :: BinPkgName -> String +apacheErrorLog x = apacheLogDirectory x "error.log" + +apacheAccessLog :: BinPkgName -> String +apacheAccessLog x = apacheLogDirectory x "access.log" + +serverLogDirectory :: BinPkgName -> String +serverLogDirectory x = "/var/log/" ++ show (pretty x) + +serverAppLog :: BinPkgName -> String +serverAppLog x = serverLogDirectory x "app.log" + +serverAccessLog :: BinPkgName -> String +serverAccessLog x = serverLogDirectory x "access.log" + +debianPackageVersion :: String -> IO DebianVersion +debianPackageVersion name = + readProcess "dpkg-query" ["--show", "--showformat=${version}", name] "" >>= + return . parseDebianVersion + +-- | Assumes debhelper is installed +getDebhelperCompatLevel :: IO Int +getDebhelperCompatLevel = + debianPackageVersion "debhelper" >>= return . read . takeWhile (/= '.') . version + +data StandardsVersion = StandardsVersion Int Int Int (Maybe Int) deriving (Eq, Ord, Show, Data, Typeable) + +instance Pretty StandardsVersion where + pretty (StandardsVersion a b c (Just d)) = text $ show a <> "." <> show b <> "." <> show c <> "." <> show d + pretty (StandardsVersion a b c Nothing) = text $ show a <> "." <> show b <> "." <> show c + +-- | Assumes debian-policy is installed +getDebianStandardsVersion :: IO StandardsVersion +getDebianStandardsVersion = debianPackageVersion "debian-policy" >>= \ v -> return (parseStandardsVersion (version v)) + +parseStandardsVersion :: String -> StandardsVersion +parseStandardsVersion s = + case filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) s) of + (a : b : c : d : _) -> StandardsVersion (read a) (read b) (read c) (Just (read d)) + (a : b : c : _) -> StandardsVersion (read a) (read b) (read c) Nothing + _ -> error $ "Invalid Standards-Version string: " ++ show s + +data SourceFormat + = Native3 + | Quilt3 + deriving (Eq, Ord, Show, Data, Typeable) + +instance Pretty SourceFormat where + pretty Quilt3 = text "3.0 (quilt)\n" + pretty Native3 = text "3.0 (native)\n" + +readSourceFormat :: Text -> Either Text SourceFormat +readSourceFormat s = + case () of + _ | strip s == "3.0 (native)" -> Right Native3 + _ | strip s == "3.0 (quilt)" -> Right Quilt3 + _ -> Left $ "Invalid debian/source/format: " <> pack (show (strip s)) + +data PackagePriority + = Required + | Important + | Standard + | Optional + | Extra + deriving (Eq, Ord, Read, Show, Data, Typeable) + +readPriority :: String -> PackagePriority +readPriority s = + case unpack (strip (pack s)) of + "required" -> Required + "important" -> Important + "standard" -> Standard + "optional" -> Optional + "extra" -> Extra + x -> error $ "Invalid priority string: " ++ show x + +instance Pretty PackagePriority where + pretty = text . map toLower . show + +-- | The architectures for which a binary deb can be built. +data PackageArchitectures + = All -- ^ The package is architecture independenct + | Any -- ^ The package can be built for any architecture + | Names [String] -- ^ The list of suitable architectures + deriving (Read, Eq, Ord, Show, Data, Typeable) + +instance Pretty PackageArchitectures where + pretty All = text "all" + pretty Any = text "any" + pretty (Names xs) = text $ intercalate " " xs + +parsePackageArchitectures :: String -> PackageArchitectures +parsePackageArchitectures "all" = All +parsePackageArchitectures "any" = Any +parsePackageArchitectures s = error $ "FIXME: parsePackageArchitectures " ++ show s + +data Section + = MainSection String -- Equivalent to AreaSection Main s? + | AreaSection Area String + deriving (Read, Eq, Ord, Show, Data, Typeable) + +readSection :: String -> Section +readSection s = + case break (== '/') s of + ("contrib", '/' : b) -> AreaSection Contrib (tail b) + ("non-free", '/' : b) -> AreaSection NonFree (tail b) + ("main", '/' : b) -> AreaSection Main (tail b) + (a, '/' : _) -> error $ "readSection - unknown area: " ++ show a + (a, _) -> MainSection a + +instance Pretty Section where + pretty (MainSection sec) = text sec + pretty (AreaSection area sec) = pretty area <> text ("/" <> sec) + +-- Is this really all that is allowed here? Doesn't Ubuntu have different areas? +data Area + = Main + | Contrib + | NonFree + deriving (Read, Eq, Ord, Show, Data, Typeable) + +instance Pretty Area where + pretty Main = text "main" + pretty Contrib = text "contrib" + pretty NonFree = text "non-free" + +{- +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 :: IO (Maybe NameAddr) +getDebianMaintainer = + 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 + either (const Nothing) Just (parseMaintainer (fullname ++ " <" ++ email ++ ">")) + +haskellMaintainer :: NameAddr +haskellMaintainer = + either error id (parseMaintainer "Debian Haskell Group ") + +parseUploaders :: String -> Either String [NameAddr] +parseUploaders x = + either (Left . show) Right (parse address "" ("Names: " ++ map fixWhite x ++ ";")) + -- either (\ e -> error ("Failure parsing uploader list: " ++ show x ++ " -> " ++ show e)) id $ + where + fixWhite c = if isSpace c then ' ' else c + +parseMaintainer :: String -> Either String NameAddr +parseMaintainer x = + case parseUploaders x of + Left s -> Left s + Right [y] -> Right y + Right [] -> Left $ "Missing maintainer: " ++ show x + Right ys -> Left $ "Too many maintainers: " ++ show ys diff --git a/src/Distribution/Version/Invert.hs b/src/Distribution/Version/Invert.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Version/Invert.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wall #-} +module Distribution.Version.Invert + ( invertVersionRange + , invertVersionIntervals + ) where + +import Distribution.Version (Version(Version, versionBranch, versionTags), VersionRange, fromVersionIntervals, asVersionIntervals, mkVersionIntervals, + LowerBound(LowerBound), UpperBound(UpperBound, NoUpperBound), Bound(InclusiveBound, ExclusiveBound)) + +invertVersionRange :: VersionRange -> VersionRange +invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals + +invertVersionIntervals :: [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] +invertVersionIntervals xs = + case xs of + [] -> [(lb0, NoUpperBound)] + ((LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound, ub) : more) -> + invertVersionIntervals' ub more + ((lb, ub) : more) -> + (lb0, invertLowerBound lb) : invertVersionIntervals' ub more + where + invertVersionIntervals' :: UpperBound -> [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] + invertVersionIntervals' NoUpperBound [] = [] + invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] + invertVersionIntervals' ub0 [(lb, NoUpperBound)] = [(invertUpperBound ub0, invertLowerBound lb)] + invertVersionIntervals' ub0 ((lb, ub1) : more) = (invertUpperBound ub0, invertLowerBound lb) : invertVersionIntervals' ub1 more + + invertLowerBound :: LowerBound -> UpperBound + invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) + + invertUpperBound :: UpperBound -> LowerBound + invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) + invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" + + invertBound :: Bound -> Bound + invertBound ExclusiveBound = InclusiveBound + invertBound InclusiveBound = ExclusiveBound + + lb0 :: LowerBound + lb0 = LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound diff --git a/src/Tests.hs b/src/Tests.hs new file mode 100644 --- /dev/null +++ b/src/Tests.hs @@ -0,0 +1,7 @@ +module Main where + +import Debian.Debianize.Tests (tests) +import Test.HUnit (runTestTT) + +main :: IO () +main = runTestTT tests >>= putStrLn . show diff --git a/src/Triplets.hs b/src/Triplets.hs new file mode 100644 --- /dev/null +++ b/src/Triplets.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, StandaloneDeriving #-} +{-# OPTIONS -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-} +module Triplets + ( gzipWithM3 + , gzipWithT3 + , gzipWithA3 + , gzip3 + , gzipQ3 + , gzipBut3 + , gzipButA3 + -- , gzipBut3' + , extQ2 + , extQ3 + , extT3 + , mkQ3 + , mkQ2 + -- , mkP3 + -- , gzip3F + , mergeBy + --, mergeByM + --, GenericA + , GB, GM, GA, PB, PM, PA + ) where + +import Prelude hiding (GT) +import Control.Applicative (Applicative(..)) +import Control.Applicative.Error (Failing(..)) +import Control.Monad (MonadPlus(mzero, mplus)) +import Data.Generics (Data, Typeable, Typeable1, toConstr, cast, gcast, gmapAccumQ, gshow, gfoldlAccum, + unGT, GenericT, GenericT'(GT), gmapAccumT, + unGM, GenericM, GenericM'(GM), gmapAccumM, + unGQ, GenericQ, GenericQ'(GQ), gmapQ) +import Data.Maybe (fromMaybe) + +instance Monad Failing where + return = Success + m >>= f = + case m of + (Failure errs) -> (Failure errs) + (Success a) -> f a + fail errMsg = Failure [errMsg] + +instance MonadPlus Failing where + mzero = Failure [] + mplus (Failure xs) (Failure ys) = Failure (xs ++ ys) + mplus success@(Success _) _ = success + mplus _ success@(Success _) = success + +deriving instance Typeable1 Failing +deriving instance Data a => Data (Failing a) +deriving instance Read a => Read (Failing a) +deriving instance Eq a => Eq (Failing a) +deriving instance Ord a => Ord (Failing a) + +cast' :: (Monad m, Typeable a, Typeable b) => a -> m b +cast' = maybe (fail "cast") return . cast + +--orElse' = mplus + +-- As originally defined: Twin map for transformation + +{- +gzipWithT2 :: GenericQ (GenericT) -> GenericQ (GenericT) +gzipWithT2 f x y = case gmapAccumT perkid funs y of + ([], c) -> c + _ -> error "gzipWithT2" + where + perkid a d = (tail a, unGT (head a) d) + funs = gmapQ (\k -> GT (f k)) x +-} + + +-- As originally defined: Twin map for transformation + +{- +gzipWithM2 :: Monad m => GenericQ (GenericM m) -> GenericQ (GenericM m) +gzipWithM2 f x y = case gmapAccumM perkid funs y of + ([], c) -> c + _ -> error "gzipWithM" + where + perkid a d = (tail a, unGM (head a) d) + funs = gmapQ (\k -> GM (f k)) x +-} + + +-- As originally defined: generic zip + +{- +gzip2 :: + (forall x. Data x => x -> x -> Maybe x) + -> (forall x. Data x => x -> x -> Maybe x) + +gzip2 f = gzip2' f' + where + f' :: GenericQ (GenericM Maybe) + f' x y = cast x >>= \x' -> f x' y + gzip2' :: GenericQ (GenericM Maybe) -> GenericQ (GenericM Maybe) + gzip2' f x y = + f x y + `orElse` + if toConstr x == toConstr y + then gzipWithM2 (gzip2' f) x y + else Nothing +-} + +-- For three args now + +--type GenericT = forall a. Data a => a -> a +--type GenericQ r = forall a. Data a => a -> r +--type GenericM m = forall a. Data a => a -> m a + +gzipWithT3 :: + GenericQ (GenericQ (GenericT)) + -> GenericQ (GenericQ (GenericT)) +gzipWithT3 f x y z = + case gmapAccumT perkid funs z of + ([], c) -> c + _ -> error "gzipWithT3" + where + perkid a d = (tail a, unGT (head a) d) + funs = case gmapAccumQ perkid' funs' y of + ([], q) -> q + _ -> error "gzipWithT3" + where + perkid' a d = (tail a, unGQ (head a) d) + funs' = gmapQ (\k -> (GQ (\k' -> GT (f k k')))) x + +gzipWithM3 :: Monad m + => GenericQ (GenericQ (GenericM m)) + -> GenericQ (GenericQ (GenericM m)) +gzipWithM3 f x y z = + case gmapAccumM perkid funs z of + ([], c) -> c + _ -> error "gzipWithM3" + where + perkid a d = (tail a, unGM (head a) d) + funs = case gmapAccumQ perkid' funs' y of + ([], q) -> q + _ -> error "gzipWithM3" + where + perkid' a d = (tail a, unGQ (head a) d) + funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x + +gzipWithA3 :: forall f. Applicative f => GA f -> GA f +gzipWithA3 f x y z = + case gmapAccumA perkid funs z of + ([], c) -> c + _ -> error "gzipWithA3" + where + perkid a d = (tail a, unGM (head a) d) + funs = case gmapAccumQ perkid' funs' y of + ([], q) -> q + _ -> error "gzipWithA3" + where + perkid' a d = (tail a, unGQ (head a) d) + funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x + +type GB = GenericQ (GenericQ (GenericQ Bool)) +-- ^ Generic Bool Query, (Data a, Data b, Data c) => a -> b -> c -> Bool +type GM = MonadPlus m => GenericQ (GenericQ (GenericM m)) +-- ^ Generic Maybe Query, (Data a, Data b, Data c) => a -> b -> c -> Maybe c +type PB = forall x. Data x => x -> x -> x -> Bool +-- ^ Polymorphic Bool Query +type PM = forall m x. (MonadPlus m, Data x) => x -> x -> x -> m x +-- ^ Polymorphic Failing Query, forall x. Data x => x -> x -> x -> Failing x +type GA f = GenericQ (GenericQ (GenericM f)) +-- ^ Generic Applicative Query, forall a. Data a => a -> (forall b. Data b => b -> (forall c. Data c => c -> f c)) +type PA f = forall x. Data x => x -> x -> x -> f x +-- ^ Polymorphic Applicative Query + +-- | gmapA with accumulation (untested) +-- (Move to Data.Generics.Twins) +gmapAccumA :: forall a d f. (Data d, Applicative f) + => (forall e. Data e => a -> e -> (a, f e)) + -> a -> d -> (a, f d) +gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0 + where + k :: forall d e. (Data d) => + a -> f (d -> e) -> d -> (a, f e) + k a c d = let (a',d') = f a d + c' = c <*> d' + in (a', c') + z :: forall t a f. (Applicative f) => + t -> a -> (t, f a) + z a x = (a, pure x) + +-- |The purpose of gzip3 is to map a polymorphic (generic) function +-- over the "elements" of three instances of a type. The function +-- returns a Maybe value of the same type as the elements passed. If +-- it returns a Just the subtree is not traversed, the returned value +-- is used. If it returns Nothing the subtree is traversed. This +-- traversal may succeed where the top level test failed, resulting in +-- a successful zip. For example, the merge function wouldn't merge +-- these three values: +-- (1, 1) (1, 2) (2, 1) -> (?, ?) +-- but it could merge the two unzipped triples: +-- (1, 1, 2) -> 2 +-- (1, 2, 1) -> 2 +-- -> (2, 2) +gzip3 :: PM -> PM +gzip3 f = gzipBut3 f gzipQ3 + +-- |This is the minimal condition for recursing into a value - the +-- constructors must all match. +gzipQ3 :: GM +gzipQ3 x y z = + if and [toConstr x == toConstr y, toConstr y == toConstr z] + then return undefined + else fail ("Conflict: x=" ++ gshow x ++ " y=" ++ gshow y ++ " z=" ++ gshow z) + +-- |This function adds a test to limit the recursion of gzip3. For +-- example, with the merge function mentioned above you might want to +-- avoid merging strings character by character: +-- +-- gzip3 merge "dim" "kim" "dip" -> Just "kip" (no!) +-- +-- so you would pass a limiting function to prevent recursing into strings: +-- +-- let continue = +-- (\ x y z -> extQ3 gzipQ3 x y z) x y z +-- where +-- stringFail :: String -> String -> String -> Bool +-- stringFail _ _ _ = False +-- gzipBut3 merge continue "dim" "kim" "dip" -> Nothing +-- +-- this can also save a lot of time examining all the heads and tails +-- of every string. +gzipBut3 :: PM -> GM -> PM +gzipBut3 merge continue x y z = + gzip3' merge' x y z + where + -- If the three elements aren't all the type of f's arguments, + -- this expression will return Nothing. Also, the f function + -- might return Nothing. In those cases we call gzipWithM3 to + -- traverse the sub-elements. + merge' :: GM + merge' x y z = cast' x >>= \x' -> cast' y >>= \y' -> merge x' y' z + gzip3' :: GM -> GM + gzip3' merge x y z = + merge x y z + `mplus` + (continue x y z >> gzipWithM3 (gzip3' merge) x y z) + +-- | gzipWithA3 plus a continue function to prevent recursion into +-- particular types. (UNTESTED) +gzipButA3 :: forall f. (Applicative f) => PM -> GB -> PA f -> PA f +gzipButA3 merge continue conflict x y z = + gzip3' x y z + where + gzip3' :: GA f + gzip3' x y z = + case merge' x y z of + Just x' -> pure x' + Nothing -> + if continue x y z + then gzipWithA3 gzip3' x y z + else conflict' x y z + merge' :: GM + merge' x y z = + case (cast x, cast y) of + (Just x', Just y') -> merge x' y' z + _ -> fail "type conflict" + conflict' :: GA f + conflict' x y z = + case (cast x, cast y) of + (Just x', Just y') -> conflict x' y' z + _ -> error "type conflict" + +-- | Not to be confused with ext2Q, this extends queries of two +-- arguments (rather than queries involving constructors with two type +-- parameters.) +extQ2 :: (Typeable a, Typeable b, Typeable d, Typeable e) + => (a -> b -> r) -> (d -> e -> r) -> a -> b -> r +extQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y') + +extQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) + => (a -> b -> c -> r) -> (d -> e -> f -> r) -> a -> b -> c -> r +extQ3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> Just (q x' y' z') + +mkQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) + => r -> (a -> b -> c -> r) -> d -> e -> f -> r +mkQ3 d q x y z = extQ3 (\ _ _ _ -> d) q x y z + +extT3 :: (Typeable a, Typeable b) + => (a -> a -> a -> Maybe a) -> (b -> b -> b -> Maybe b) -> a -> a -> a -> Maybe a +extT3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> gcast (q x' y' z') + +mkQ2 :: (Data a, Data b, Data c) => (a -> b -> r) -> (c -> c -> r) -> a -> b -> r +mkQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y') + +-- |This function implements the f function used to do three way +-- merging. A triplet (original, new1, new2) conflicts if the two +-- new values each differ from the original, and from each other. +-- Otherwise, the new value that differs from the original is kept, or +-- either of the new values if they match. However, even if the +-- values conflict, it still might be possible to do the merge by +-- examining the components of the value. So conflict is typically +-- (\ _ _ _ -> Nothing), while eq could be geq, but it could also +-- just return false for more complex datatypes that we don't want +-- to repeatedly traverse. +mergeBy :: forall a m. MonadPlus m => (a -> a -> a -> m a) -> (a -> a -> Bool) -> a -> a -> a -> m a +mergeBy conflict eq original left right = + if eq original left then return right + else if eq original right then return left + else if eq left right then return left + else conflict original left right