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: 3.9 +Version: 4.0.3 License: BSD3 License-File: debian/copyright Author: David Fox @@ -10,8 +10,125 @@ Synopsis: Create a debianization for a cabal package Cabal-Version: >= 1.8 Extra-Source-Files: - changelog, + changelog debian/Debianize.hs + -- These files are omitted pending a fix for https://github.com/haskell/hackage-server/issues/171 + -- You can get them from http://src.seereason.com/debian-tools. + -- test-data/creativeprompts/input/debian/changelog + -- test-data/creativeprompts/input/debian/copyright + -- test-data/creativeprompts/input/creativeprompts.cabal + -- test-data/creativeprompts/output/debian/creativeprompts-development.init + -- test-data/creativeprompts/output/debian/creativeprompts-development.logrotate + -- test-data/creativeprompts/output/debian/watch + -- test-data/creativeprompts/output/debian/creativeprompts-production.logrotate + -- test-data/creativeprompts/output/debian/creativeprompts-production.install + -- test-data/creativeprompts/output/debian/cabalInstall/a1cb9e4b5241944a3da44e00220b5c31/creativeprompts.com + -- test-data/creativeprompts/output/debian/creativeprompts-production.links + -- test-data/creativeprompts/output/debian/changelog + -- test-data/creativeprompts/output/debian/creativeprompts-production.postinst + -- test-data/creativeprompts/output/debian/creativeprompts-backups.install + -- test-data/creativeprompts/output/debian/creativeprompts-development.postinst + -- test-data/creativeprompts/output/debian/creativeprompts-backups.postinst + -- test-data/creativeprompts/output/debian/creativeprompts-production.dirs + -- test-data/creativeprompts/output/debian/rules + -- test-data/creativeprompts/output/debian/compat + -- test-data/creativeprompts/output/debian/source/format + -- test-data/creativeprompts/output/debian/control + -- test-data/creativeprompts/output/debian/creativeprompts-data.install + -- test-data/creativeprompts/output/debian/creativeprompts-production.init + -- test-data/creativeprompts/output/debian/copyright + -- test-data/clckwrks-dot-com/input/debian/changelog + -- test-data/clckwrks-dot-com/input/debian/Debianize.hs + -- test-data/clckwrks-dot-com/input/LICENSE + -- test-data/clckwrks-dot-com/input/clckwrks-dot-com.cabal + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.postinst + -- test-data/clckwrks-dot-com/output/debian/watch + -- test-data/clckwrks-dot-com/output/debian/cabalInstall/6cb4323c6b76525f567919adaf912663/clckwrks.com + -- test-data/clckwrks-dot-com/output/debian/changelog + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.links + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-backups.postinst + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.logrotate + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-backups.install + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.install + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.init + -- test-data/clckwrks-dot-com/output/debian/Debianize.hs + -- test-data/clckwrks-dot-com/output/debian/rules + -- test-data/clckwrks-dot-com/output/debian/compat + -- test-data/clckwrks-dot-com/output/debian/source/format + -- test-data/clckwrks-dot-com/output/debian/control + -- test-data/clckwrks-dot-com/output/debian/copyright + -- test-data/clckwrks-dot-com/output/debian/clckwrks-dot-com-production.dirs + -- test-data/haskell-devscripts/debian/manpages + -- test-data/haskell-devscripts/debian/changelog + -- test-data/haskell-devscripts/debian/install + -- test-data/haskell-devscripts/debian/rules + -- test-data/haskell-devscripts/debian/compat + -- test-data/haskell-devscripts/debian/dirs + -- test-data/haskell-devscripts/debian/source/format + -- test-data/haskell-devscripts/debian/control + -- test-data/haskell-devscripts/debian/copyright + -- test-data/haskell-devscripts/debian/docs + -- test-data/alex/input/LICENSE + -- test-data/alex/input/alex.cabal + -- test-data/alex/output/debian/watch + -- test-data/alex/output/debian/alex.install + -- test-data/alex/output/debian/changelog + -- test-data/alex/output/debian/rules + -- test-data/alex/output/debian/compat + -- test-data/alex/output/debian/source/format + -- test-data/alex/output/debian/control + -- test-data/alex/output/debian/copyright + -- test-data/artvaluereport-data/input/debian/changelog + -- test-data/artvaluereport-data/input/artvaluereport-data.cabal + -- test-data/artvaluereport-data/input/Debianize.hs + -- test-data/artvaluereport-data/output/debian/watch + -- test-data/artvaluereport-data/output/debian/extra-depends + -- test-data/artvaluereport-data/output/debian/changelog + -- test-data/artvaluereport-data/output/debian/libghc-artvaluereport-data-doc.links + -- test-data/artvaluereport-data/output/debian/Debianize.hs + -- test-data/artvaluereport-data/output/debian/rules + -- test-data/artvaluereport-data/output/debian/compat + -- test-data/artvaluereport-data/output/debian/source/format + -- test-data/artvaluereport-data/output/debian/control + -- test-data/artvaluereport-data/output/debian/copyright + -- test-data/archive/input/debian/changelog + -- test-data/archive/input/debian/copyright + -- test-data/archive/input/seereason-darcs-backups.cabal + -- test-data/archive/output/debian/watch + -- test-data/archive/output/debian/changelog + -- test-data/archive/output/debian/rules + -- test-data/archive/output/debian/compat + -- test-data/archive/output/debian/control + -- test-data/archive/output/debian/seereason-darcs-backups.install + -- test-data/archive/output/debian/copyright + -- test-data/artvaluereport2/input/artvaluereport2.cabal + -- test-data/artvaluereport2/input/debian/changelog + -- test-data/artvaluereport2/input/debian/Debianize.hs + -- test-data/artvaluereport2/output/debian/artvaluereport2-development.init + -- test-data/artvaluereport2/output/debian/artvaluereport2-staging.postinst + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.postinst + -- test-data/artvaluereport2/output/debian/watch + -- test-data/artvaluereport2/output/debian/cabalInstall/7e4b5d8641f6fae99e9ae9b2d8893bc7/my.appraisalreportonline.com + -- test-data/artvaluereport2/output/debian/artvaluereport2-staging.install + -- test-data/artvaluereport2/output/debian/artvaluereport2-staging.init + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.install + -- test-data/artvaluereport2/output/debian/changelog + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.logrotate + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.links + -- test-data/artvaluereport2/output/debian/artvaluereport2-development.logrotate + -- test-data/artvaluereport2/output/debian/artvaluereport2-backups.postinst + -- test-data/artvaluereport2/output/debian/artvaluereport2-development.install + -- test-data/artvaluereport2/output/debian/artvaluereport2-development.postinst + -- test-data/artvaluereport2/output/debian/artvaluereport2-staging.logrotate + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.init + -- test-data/artvaluereport2/output/debian/artvaluereport2-production.dirs + -- test-data/artvaluereport2/output/debian/rules + -- test-data/artvaluereport2/output/debian/compat + -- test-data/artvaluereport2/output/debian/appraisalscope.install + -- test-data/artvaluereport2/output/debian/control + -- test-data/artvaluereport2/output/debian/artvaluereport2-backups.install + -- test-data/artvaluereport2/output/debian/copyright + Description: This package provides two methods for generating the debianization (i.e. the contents of the 'debian' subdirectory) for a cabal package. @@ -37,6 +154,7 @@ Cabal >= 1.9, containers, data-lens, + data-lens-template, debian >= 3.71, Diff, directory, @@ -48,6 +166,7 @@ process, pureMD5, regex-tdfa, + set-extra, syb, text, unix, @@ -56,48 +175,72 @@ Data.Algorithm.Diff.Context Data.Algorithm.Diff.Pretty Debian.Debianize - Debian.Debianize.Atoms + Debian.Policy + Distribution.Version.Invert Debian.Debianize.Bundled - Debian.Debianize.ControlFile - Debian.Debianize.Debianize - Debian.Debianize.Dependencies + Debian.Debianize.Changelog + Debian.Debianize.DebianName Debian.Debianize.Details Debian.Debianize.Files Debian.Debianize.Finalize Debian.Debianize.Goodies - Debian.Debianize.Interspersed Debian.Debianize.Input + Debian.Debianize.Interspersed + Debian.Debianize.Monad Debian.Debianize.Options + Debian.Debianize.Output + Debian.Debianize.Prelude Debian.Debianize.SubstVars Debian.Debianize.Types - Debian.Debianize.Types.VersionSplits - Debian.Debianize.Utility + Debian.Debianize.Types.Atoms + Debian.Debianize.Types.Base + Debian.Debianize.Types.BinaryDebDescription + Debian.Debianize.Types.SourceDebDescription Debian.Debianize.VersionSplits + Other-Modules: Debian.Orphans - Debian.Policy - Distribution.Version.Invert Executable cabal-debian - Main-is: src/CabalDebian.hs + Hs-Source-Dirs: src + Main-is: CabalDebian.hs ghc-options: -threaded -Wall -O2 Build-Depends: + ansi-wl-pprint, base, Cabal, - cabal-debian, containers, - data-lens + data-lens, + data-lens-template, + debian, + Diff, + directory, + filepath, + hsemail, + mtl, + parsec, + process, + pureMD5, + regex-tdfa, + set-extra, + syb, + text, + unix, + utf8-string Executable cabal-debian-tests - Main-is: src/Debian/Debianize/Tests.hs + Hs-Source-Dirs: src + Main-is: Debian/Debianize/Tests.hs ghc-options: -threaded -Wall -O2 Build-Depends: ansi-wl-pprint, base, Cabal, - cabal-debian, containers, data-lens, + data-lens-template, debian, + Diff, + directory, filepath, hsemail, HUnit, @@ -106,33 +249,8 @@ process, pureMD5, regex-tdfa, + set-extra, syb, text, unix, utf8-string - --- Executable cabal-debian-tests --- Main-Is: src/Tests.hs --- GHC-Options: -Wall -O2 -threaded -rtsopts --- Build-Depends: --- ansi-wl-pprint, --- base, --- Cabal, --- cabal-debian, --- containers, --- data-lens, --- debian, --- Diff, --- directory, --- filepath, --- hsemail, --- HUnit, --- mtl, --- parsec, --- process, --- pureMD5, --- regex-tdfa, --- syb, --- text, --- unix, --- utf8-string diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,55 @@ +haskell-cabal-debian (4.0.3) unstable; urgency=low + + * Include the build dependencies of the executables in the debian + source deb build dependencies. + + -- David Fox Tue, 10 Dec 2013 14:37:20 -0800 + +haskell-cabal-debian (4.0.2) unstable; urgency=low + + * Export some lens state operators from Prelude. + + -- David Fox Tue, 10 Dec 2013 05:38:00 -0800 + +haskell-cabal-debian (4.0.1) unstable; urgency=low + + * Make sure the utilities package gets created even if no name + has been specified for it - use the name generated in DebianNames.hs. + + -- David Fox Tue, 10 Dec 2013 05:10:11 -0800 + +haskell-cabal-debian (4.0.0) unstable; urgency=low + + * Massive lens overhaul + + -- David Fox Thu, 05 Dec 2013 12:26:31 -0800 + +haskell-cabal-debian (3.10.3) unstable; urgency=low + + * Go back to using lens interface directly + * Collect debianization fact code in Facts/ + + -- David Fox Sun, 24 Nov 2013 10:40:02 -0800 + +haskell-cabal-debian (3.10.2) unstable; urgency=low + + * Make some signatures in Monad.hs clearer + + -- David Fox Wed, 20 Nov 2013 14:26:28 -0800 + +haskell-cabal-debian (3.10.1) unstable; urgency=low + + * More API changes - want need to get all the clients in sync before + proceeding. + + -- David Fox Tue, 19 Nov 2013 11:31:16 -0800 + +haskell-cabal-debian (3.10) unstable; urgency=low + + * Add a monadic interface + + -- David Fox Sat, 16 Nov 2013 10:42:02 -0800 + haskell-cabal-debian (3.9) unstable; urgency=low * Clean up documentation diff --git a/debian/Debianize.hs b/debian/Debianize.hs --- a/debian/Debianize.hs +++ b/debian/Debianize.hs @@ -1,12 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} -import Data.Lens.Lazy -import Data.Map as Map (insertWith) -import Data.Maybe (fromMaybe) -import Data.Set as Set (insert, union, singleton) -import Data.Text as Text (intercalate) -import Debian.Debianize as Atoms -import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Control.Monad.State (get) +import Data.Lens.Lazy (getL, access) +import Data.List (intercalate) +import Data.Monoid (mempty) +import Data.Set (singleton) +import Data.Text as Text (pack) +import Debian.Changes (ChangeLog(ChangeLog)) +import Debian.Debianize (inputChangeLog, inputDebianization) import Debian.Debianize.Details (seereasonDefaultAtoms) +import Debian.Debianize.Finalize (debianization) +import Debian.Debianize.Types as T + (changelog, compat, conflicts, control, depends, debianDescription, homepage, + installCabalExec, sourceFormat, standardsVersion, utilsPackageNames, copyright) +import Debian.Debianize.Types.Atoms as T (Atoms, newAtoms) +import Debian.Debianize.Monad (Atoms, DebT, execDebT, evalDebT, execDebM) +import Debian.Debianize.Output (compareDebianization) +import Debian.Debianize.Prelude ((~=), (~?=), (%=), (+=), (++=), (+++=)) +import Debian.Debianize.Types (Top(Top)) +import Debian.Debianize.Types.SourceDebDescription (SourceDebDescription) +import Debian.Policy (SourceFormat(Native3), StandardsVersion(StandardsVersion)) import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT, GRE)) import Debian.Version (parseDebianVersion) import Prelude hiding (log) @@ -14,49 +25,66 @@ main :: IO () main = - do -- Copy the changelog into the top directory so that hackage + do let top = Top "." + -- Copy the changelog into the top directory so that hackage -- will see it. copyFile "debian/changelog" "changelog" - log <- inputChangeLog (Top ".") - new <- debianization (Top ".") (return . customize . setL changelog (Just log)) seereasonDefaultAtoms - old <- inputDebianization (Top ".") - case compareDebianization old (copyFirstLogEntry old new) of + log <- evalDebT (inputChangeLog top >> access changelog) newAtoms + old <- execDebT (inputDebianization top) newAtoms + new <- execDebT (debianization top seereasonDefaultAtoms (changelog ~?= log >> customize >> copyFirstLogEntry old)) newAtoms + diff <- compareDebianization old new + case diff of "" -> return () s -> error $ "Debianization mismatch:\n" ++ s -- This would overwrite the existing debianization rather than -- just make sure it matches: -- writeDebianization "." new where + customize :: Monad m => DebT m () customize = - (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) . - setL compat (Just 7) . - setL standards (Just (StandardsVersion 3 9 3 Nothing)) . - setL sourceFormat (Just Native3) . - -- modL extraDevDeps (Set.insert (BinPkgName "debian-policy")) . - setL utilsPackageNames (Just (singleton (BinPkgName "cabal-debian"))) . - modL installCabalExec (Map.insertWith union (BinPkgName "cabal-debian-tests") (singleton ("cabal-debian-tests", "/usr/bin"))) . - modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") Nothing Nothing))) . - modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) . - modL Atoms.depends (Map.insertWith union (BinPkgName "libghc-cabal-debian-dev") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) . - modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debhelper") Nothing Nothing))) . - modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8.19" :: String)))) 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 " ]))) + do sourceFormat ~= Just Native3 + standardsVersion ~= Just (StandardsVersion 3 9 3 Nothing) + compat ~= Just 7 + copyright ~= Just (pack (unlines [ "This package is not part of the Debian GNU/Linux distribution." + , "" + , "Copyright: (c) 2010-2011, SeeReason Partners LLC" + , "License: All Rights Reserved"])) + debianDescription (BinPkgName "cabal-debian") ~= + Just (pack (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 " ])) + conflicts (BinPkgName "cabal-debian") %= (++ [[Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing]]) + depends (BinPkgName "cabal-debian") %= (++ [[Rel (BinPkgName "apt-file") Nothing Nothing]]) + depends (BinPkgName "cabal-debian") %= (++ [[Rel (BinPkgName "debian-policy") Nothing Nothing]]) + depends (BinPkgName "libghc-cabal-debian-dev") %= (++ [[Rel (BinPkgName "debian-policy") Nothing Nothing]]) + depends (BinPkgName "cabal-debian") %= (++ [[Rel (BinPkgName "debhelper") Nothing Nothing]]) + depends (BinPkgName "cabal-debian") %= (++ [[Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8.19" :: String)))) Nothing]]) + installCabalExec +++= (BinPkgName "cabal-debian-tests", singleton ("cabal-debian-tests", "/usr/bin")) + installCabalExec +++= (BinPkgName "cabal-debian", singleton ("cabal-debian", "/usr/bin")) + utilsPackageNames += BinPkgName "cabal-debian" + -- extraDevDeps (BinPkgName "debian-policy") + homepage ~= Just (pack "http://src.seereason.com/cabal-debian") -- | 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 :: Monad m => Atoms -> DebT m () +copyFirstLogEntry src = + do dst <- get + let Just (ChangeLog (hd1 : _)) = getL T.changelog src + Just (ChangeLog (_ : tl2)) = getL T.changelog dst + changelog ~= Just (ChangeLog (hd1 : tl2)) +{- + get >>= \ dst -> 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/src/CabalDebian.hs b/src/CabalDebian.hs --- a/src/CabalDebian.hs +++ b/src/CabalDebian.hs @@ -5,24 +5,48 @@ -- function directly, many sophisticated configuration options cannot -- be accessed using the command line interface. -import Data.Lens.Lazy (setL) -import Data.Map as Map (fromList) -import Data.Monoid (mempty) -import Data.Version (Version(Version)) -import Debian.Debianize.Atoms (Atoms, epochMap) -import Debian.Debianize.Debianize (cabalDebian) -import Debian.Debianize.VersionSplits (mapCabal, splitCabal) -import Distribution.Package (PackageName(PackageName)) +import Control.Monad.State (get, lift) +import Data.Lens.Lazy (getL) +import Data.List as List (unlines) +import Debian.Debianize.Details (debianDefaultAtoms) +import Debian.Debianize.Finalize (debianization) +import Debian.Debianize.Monad (DebT, evalDebT) +import Debian.Debianize.Options (compileCommandlineArgs, compileEnvironmentArgs, options) +import Debian.Debianize.Output (doDebianizeAction) +import Debian.Debianize.SubstVars (substvars) +import Debian.Debianize.Types (Top(Top)) +import Debian.Debianize.Types.Atoms (DebAction(Debianize, SubstVar, Usage), debAction, newAtoms) +import Prelude hiding (unlines, writeFile, init) +import System.Console.GetOpt (usageInfo) +import System.Environment (getProgName) +top :: Top +top = Top "." + main :: IO () -main = cabalDebian defaultAtoms +main = cabalDebianMain debianDefaultAtoms -defaultAtoms :: Atoms -defaultAtoms = - setL epochMap (fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . - splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . - mapCabal (PackageName "parsec") "parsec3" . - splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . - mapCabal (PackageName "QuickCheck") "quickcheck2" . - mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ - mempty +-- | The main function for the cabal-debian executable. +cabalDebianMain :: DebT IO () -> IO () +cabalDebianMain init = + -- This picks up the options required to decide what action we are + -- taking. Much of this will be repeated in the call to debianize. + evalDebT (init >> compileEnvironmentArgs >> compileCommandlineArgs >> + get >>= return . getL debAction >>= finish) newAtoms + where + finish (SubstVar debType) = substvars top debType + finish Debianize = debianization top (return ()) (return ()) >> doDebianizeAction top + finish Usage = do + progName <- lift getProgName + let info = unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: " + , "" + , " " ++ progName ++ " --maintainer 'Maintainer Name '." + , "" + , "This will read the package's cabal file and any existing debian/changelog file and" + , "deduce what it can about the debianization, then it will create or modify files in" + , "the debian subdirectory. Note that it will not remove any files in debian, and" + , "these could affect the operation of the debianization in unknown ways. For this" + , "reason I recommend either using a pristine unpacked directory each time, or else" + , "using a revision control system to revert the package to a known state before running." + , "The following additional options are available:" ] + lift $ putStrLn (usageInfo info options) diff --git a/src/Debian/Debianize.hs b/src/Debian/Debianize.hs --- a/src/Debian/Debianize.hs +++ b/src/Debian/Debianize.hs @@ -1,4 +1,6 @@ --- | QUICK START: You can either run the @cabal-debian --debianize@, or +-- | [/QUICK START:/] +-- +-- You can either run the @cabal-debian --debianize@, or -- for more power and flexibility you can put a @Debianize.hs@ script in -- the package's @debian@ subdirectory. -- 'Debian.Debianize.Atoms' value and pass it to the @@ -7,24 +9,24 @@ -- 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 Data.Lens.Lazy -- > import Data.Map as Map (insertWith) -- > import Data.Set as Set (union, singleton) @@ -33,48 +35,145 @@ -- > main = debianization "." defaultAtoms >>= -- > return . modL depends (insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) >>= -- > writeDebianization "." --- +-- -- Then to test it, --- +-- -- > % CABALDEBIAN='["-n"]' runhaskell debian/Debianize.hs --- +-- -- or equivalently --- +-- -- > % ghc -e 'Debian.Debianize.runDebianize ["-n"]' --- +-- -- and to run it for real: --- +-- -- > % runhaskell debian/Debianize.hs +-- +-- [/DESIGN OVERVIEW/] +-- +-- The three phases of the operation of the system are Input -> Finalization -> Output. +-- +-- [Input] Module "Debian.Debianize.Input" - gather inputs using IO +-- operations and customization functions, from the .cabal file, an +-- existing debianization, and so on. This information results in +-- a value of type @Atoms@. Modules @Types@, @Lenses@, @Inputs@. +-- +-- [Customize] Make modifications to the input values +-- +-- [Finalization] Module "Debian.Debianize.Finalize" - Fill in any +-- information missing from @Atoms@ that is required to build the +-- debianization based on the inputs and our policy decisions. +-- +-- [Debianize] Module "Debian.Debianize.Files" - Compute the paths +-- and files of the debianization from the Atoms value. +-- +-- [Output] Module "Debian.Debianize.Output" - Perform a variety of +-- output operations on the debianzation - writing or updating the +-- files in a debian directory, comparing two debianizations, +-- validate a debianization (ensure two debianizations match in +-- source and binary package names), or describe a debianization. +-- +-- There is also a high level function to run a script that runs this +-- entire pipeline when it finds from a script found in a +-- debian/Debianize.hs file. + +{- + Types.hs + Monad.hs + Lenses.hs + + Input.hs + + * Files.hs + + Output.hs + + Bundled.hs + Changelog.hs + DebianName.hs + Details.hs + Finalize.hs + Goodies.hs + Interspersed.hs + Options.hs + SubstVars.hs + Tests.hs + Utility.hs + VersionSplits.hs +-} module Debian.Debianize - ( module Debian.Debianize.Atoms + ( Debian.Debianize.Finalize.debianization + + , Debian.Debianize.Output.doDebianizeAction + , Debian.Debianize.Output.runDebianizeScript + , Debian.Debianize.Output.writeDebianization + , Debian.Debianize.Output.describeDebianization + , Debian.Debianize.Output.compareDebianization + , Debian.Debianize.Output.validateDebianization + + , Debian.Debianize.Details.debianDefaultAtoms + , Debian.Debianize.Details.seereasonDefaultAtoms + + , Debian.Debianize.Goodies.tightDependencyFixup + , Debian.Debianize.Goodies.doExecutable + , Debian.Debianize.Goodies.doServer + , Debian.Debianize.Goodies.doWebsite + , Debian.Debianize.Goodies.doBackups + + , Debian.Debianize.Input.inputDebianization + , Debian.Debianize.Input.inputDebianizationFile + , Debian.Debianize.Input.inputChangeLog + , Debian.Debianize.Input.inputMaintainer + + -- * Deb monad - 'Debian.Debianize.Monad' + , DebT, runDebT, execDebT, evalDebT, DebM, runDebM, execDebM, evalDebM + + , Debian.Debianize.DebianName.mapCabal + , Debian.Debianize.DebianName.splitCabal + , Debian.Debianize.Options.compileArgs + , Debian.Debianize.SubstVars.substvars + + -- * Utility functions + + , Debian.Debianize.Prelude.withCurrentDirectory + , Debian.Debianize.Prelude.buildDebVersionMap + , Debian.Debianize.Prelude.dpkgFileMap + , Debian.Debianize.Prelude.debOfFile + , (~=) + , (~?=) + , (%=) + , (+=) + , (++=) + , (+++=) + + -- * TBD + + , module Debian.Debianize.Types + , module Debian.Debianize.Types.Atoms + , module Debian.Policy +{- , 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.Goodies - , module Debian.Debianize.Input , module Debian.Debianize.Interspersed - , module Debian.Debianize.Options - , module Debian.Debianize.SubstVars - , module Debian.Debianize.Types - , module Debian.Debianize.Utility - , module Debian.Policy + , module Debian.Debianize.VersionSplits +-} ) where -import Debian.Debianize.Atoms -import Debian.Debianize.Bundled -import Debian.Debianize.Debianize -import Debian.Debianize.Dependencies -import Debian.Debianize.Files +-- import Debian.Debianize.Bundled +import Debian.Debianize.DebianName +import Debian.Debianize.Details +-- import Debian.Debianize.Files import Debian.Debianize.Finalize import Debian.Debianize.Goodies import Debian.Debianize.Input -import Debian.Debianize.Interspersed +-- import Debian.Debianize.Interspersed +import Debian.Debianize.Monad +import Debian.Debianize.Prelude +import Debian.Debianize.Types +import Debian.Debianize.Types.Atoms import Debian.Debianize.Options +import Debian.Debianize.Output import Debian.Debianize.SubstVars -import Debian.Debianize.Types -import Debian.Debianize.ControlFile hiding (depends, conflicts, maintainer, description, section) -import Debian.Debianize.Utility +-- import Debian.Debianize.VersionSplits import Debian.Policy diff --git a/src/Debian/Debianize/Atoms.hs b/src/Debian/Debianize/Atoms.hs deleted file mode 100644 --- a/src/Debian/Debianize/Atoms.hs +++ /dev/null @@ -1,1261 +0,0 @@ -{-# 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 - , debianNameMap - , epochMap - -- * High level information about the debianization - , description - , executable - , serverInfo - , website - , backups - , apacheSite - , missingDependencies - , utilsPackageNames - , sourcePackageName - , revision - , debVersion - , maintainer - , packageInfo - , omitLTDeps - , noProfilingLibrary - , noDocumentationLibrary - , copyright - , sourceArchitecture - , binaryArchitectures - , sourcePriority - , binaryPriorities - , sourceSection - , binarySections - , buildDeps - , buildDepsIndep - , depends - , conflicts - , replaces - , provides - , 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.Char (toLower) -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(..), DebAction(..)) -import Debian.Debianize.Types.VersionSplits (VersionSplits) -import Debian.Orphans () -import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion) -import Debian.Relation (SrcPkgName, BinPkgName, Relations, 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 - | UtilsPackageNames (Set BinPkgName) -- ^ Names of the packages that will get 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. - | 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. - | DebianNameMap (Map PackageName VersionSplits) - -- ^ Mapping from cabal package name and version to debian source - -- package name. This allows different ranges of cabal versions to - -- map to different debian source package names. - | SourcePackageName SrcPkgName -- ^ Name to give to the debian source package. If not supplied - -- the name is constructed from the cabal package name. Note that - -- DebianNameMap could encode this information if we already knew - -- the cabal package name, but we can't assume that. - | BuildDep Relations -- ^ Add build dependencies - | BuildDepIndep Relations -- ^ Add arch independent build dependencies - | 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 Relations -- ^ Map a cabal Extra-Library name to a debian binary package name, - -- e.g. @ExtraLibMapping extraLibMap "cryptopp" "libcrypto-dev"@ adds a - -- build dependency *and* a regular dependency on @libcrypto-dev@ to - -- any package that has @cryptopp@ in its cabal Extra-Library list. - | ExecMapping String Relations -- ^ 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 - | Provides Relation -- ^ Says that the debian package should have this relation in Provides - | Replaces Relation -- ^ Says that the debian package should have this relation in Replaces - | DevDepends Relation -- ^ 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 supplied --- and generated debianizations match. -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" map toLower pkgname) (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 Relations)) -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 Relations) -execMap = lens g s - where - g :: Atoms -> Map String Relations - g atoms = foldAtoms from Map.empty atoms - where - from :: DebAtomKey -> DebAtom -> Map String Relations -> Map String Relations - from Source (ExecMapping cabal debian) x = Map.insertWith (error "Conflict in execMap") cabal debian x - from _ _ x = x - s :: Map String Relations -> Atoms -> Atoms - 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. -debianNameMap :: Lens Atoms (Map PackageName VersionSplits) -debianNameMap = lens g s - where - g atoms = foldAtoms from mempty atoms - where - from Source (DebianNameMap mp) _ = mp - from _ _ mp = mp - s x atoms = insertAtom Source (DebianNameMap x) (deleteAtoms p atoms) - where - p Source (DebianNameMap _) = 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 (\ k a -> error $ "executable: " ++ show (k, a)) 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. --- Usually only one package is specified, but if more then one are they will each --- receive the same list of files. -utilsPackageNames :: Lens Atoms (Maybe (Set BinPkgName)) -utilsPackageNames = lens g s - where - g atoms = foldAtoms from Nothing atoms - where - from Source (UtilsPackageNames xs') (Just xs) | xs /= xs' = error $ "Conflicting compat values:" ++ show (xs, xs') - from Source (UtilsPackageNames xs) _ = Just xs - from _ _ xs = xs - s xs atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . UtilsPackageNames) xs)) atoms - where - f Source (UtilsPackageNames ys) = Just ys - 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. FIXME: This should be a Set (Set Relation) --- so we can build or relations, right now we just assume that each --- Relation is a singleton set. -buildDeps :: Lens Atoms (Set Relations) -buildDeps = lens g s - where - g atoms = foldAtoms from Set.empty atoms - where - from Source (BuildDep r) x = Set.insert r 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 Relations) -buildDepsIndep = lens g s - where - g atoms = foldAtoms from Set.empty atoms - where - from Source (BuildDepIndep r) x = Set.insert r x - from _ _ x = x - s r atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) r - 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 - --- | Map of extra install replaces for the package's binary debs. --- We should support all the other dependency fields - provides, replaces, etc. -replaces :: Lens Atoms (Map BinPkgName (Set Relation)) -replaces = lens g s - where - g atoms = foldAtoms from Map.empty atoms - where - from (Binary b) (Replaces 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) (Replaces rel) atoms'') atoms' rels) (deleteAtoms p atoms) x - where - p (Binary _) (Replaces _) = True - p _ _ = False - --- | Map of extra install provides for the package's binary debs. --- We should support all the other dependency fields - provides, replaces, etc. -provides :: Lens Atoms (Map BinPkgName (Set Relation)) -provides = lens g s - where - g atoms = foldAtoms from Map.empty atoms - where - from (Binary b) (Provides 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) (Provides rel) atoms'') atoms' rels) (deleteAtoms p atoms) x - where - p (Binary _) (Provides _) = 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 Relation) -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) - --- | Add a stanza to the binary package's logrotate script. -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 - --- | Add entries to a binary deb's debian/foo.links file. -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 by adding entries to the binary --- deb's debian/foo.install file. -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. This is done by adding rules to debian/rules. -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 a binary deb's data directory, --- /usr/share/packagename-version. This expands to either an install --- or an installTo. -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 binary deb with the given text. This is done by --- writing the file into the cabalInstall directory and adding an entry --- to the binary deb's .install file. -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 into a binary deb. -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_ = Debianize - , 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 --- a/src/Debian/Debianize/Bundled.hs +++ b/src/Debian/Debianize/Bundled.hs @@ -10,7 +10,7 @@ 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.Simple.Compiler (CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-}) import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-}) type Bundled = (CompilerFlavor, Version, [PackageIdentifier]) @@ -26,8 +26,8 @@ -- (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}) = +ghcBuiltIns :: CompilerId -> Bundled +ghcBuiltIns (CompilerId GHC compilerVersion) = case Map.lookup compilerVersion (Map.fromList (map (\ (cmp, ver, lst) -> (ver, (cmp, ver, lst))) [ (GHC, Version [7,6,3] [], ghc763BuiltIns) @@ -49,9 +49,9 @@ , (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" +ghcBuiltIns _ = error "ghcBuiltIns: Only GHC is supported" -ghcBuiltIn :: Compiler -> PackageName -> Bool +ghcBuiltIn :: CompilerId -> PackageName -> Bool ghcBuiltIn compiler package = Data.Set.member package diff --git a/src/Debian/Debianize/Changelog.hs b/src/Debian/Debianize/Changelog.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Changelog.hs @@ -0,0 +1,31 @@ +module Debian.Debianize.Changelog + ( filterEntries + , dropFutureEntries + , findChangelogEntry + , mergeChangelogEntries + ) where + +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Version (DebianVersion) +import Prelude hiding (log) + +-- | Apply a filter to the version numbers of the changelog entries. +filterEntries :: (DebianVersion -> Bool) -> ChangeLog -> ChangeLog +filterEntries p (ChangeLog entries) = ChangeLog $ filter (p . logVersion) $ entries + +-- | Filter out versions newer than the given one. +dropFutureEntries :: DebianVersion -> ChangeLog -> ChangeLog +dropFutureEntries ver log = filterEntries (<= ver) log + +-- | Find the log entry with the given version. +findChangelogEntry :: DebianVersion -> ChangeLog -> Maybe ChangeLogEntry +findChangelogEntry ver log = + case filterEntries (== ver) log of + ChangeLog [] -> Nothing + ChangeLog [x] -> Just x + _ -> error $ "Multiple version " ++ show ver ++ " changelog entries" + +mergeChangelogEntries :: ChangeLogEntry -> ChangeLogEntry -> ChangeLogEntry +mergeChangelogEntries old new = + old { logComments = logComments old ++ logComments new + , logDate = logDate new } diff --git a/src/Debian/Debianize/ControlFile.hs b/src/Debian/Debianize/ControlFile.hs deleted file mode 100644 --- a/src/Debian/Debianize/ControlFile.hs +++ /dev/null @@ -1,206 +0,0 @@ --- | 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/DebianName.hs b/src/Debian/Debianize/DebianName.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/DebianName.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} +{-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-} +module Debian.Debianize.DebianName + ( debianName -- Used in Debian.Debianize.Files and + , mkPkgName + , mkPkgName' + , mapCabal + , splitCabal + ) where + +import Data.Char (toLower) +import Data.Lens.Lazy (access) +import Data.Map as Map (lookup, alter) +import Data.Version (Version, showVersion) +import Debian.Debianize.Types.BinaryDebDescription as Debian (PackageType(..)) +import Debian.Debianize.Types.Atoms as T (debianNameMap, packageDescription) +import Debian.Debianize.Monad (DebT) +import Debian.Debianize.Prelude ((%=)) +import Debian.Debianize.VersionSplits (insertSplit, doSplits, VersionSplits, makePackage) +import Debian.Orphans () +import Debian.Relation (PkgName(..), Relations) +import qualified Debian.Relation as D (VersionReq(EEQ)) +import Debian.Version (parseDebianVersion) +import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName(PackageName)) +import qualified Distribution.PackageDescription as Cabal +import Prelude hiding (unlines) + +data Dependency_ + = BuildDepends Dependency + | BuildTools Dependency + | PkgConfigDepends Dependency + | ExtraLibs Relations + deriving (Eq, Show) + +-- | Build the Debian package name for a given package type. +debianName :: (Monad m, PkgName name) => PackageType -> DebT m name +debianName typ = + do Just pkgDesc <- access packageDescription + let pkgId = Cabal.package pkgDesc + nameMap <- access T.debianNameMap + return $ debianName' (Map.lookup (pkgName pkgId) nameMap) typ pkgId + +-- | 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) => Maybe VersionSplits -> PackageType -> PackageIdentifier -> name +debianName' msplits typ pkgId = + case msplits of + Nothing -> mkPkgName pname typ + Just splits -> (\ s -> mkPkgName' s typ) $ doSplits splits version + where + -- def = mkPkgName pname typ + pname@(PackageName _) = pkgName pkgId + version = (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion pkgId))))) + +-- | 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 pkg typ = mkPkgName' (debianBaseName pkg) typ + +mkPkgName' :: PkgName name => String -> PackageType -> name +mkPkgName' base 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 + +debianBaseName :: PackageName -> String +debianBaseName (PackageName name) = + map (fixChar . toLower) name + where + -- Underscore is prohibited in debian package names. + fixChar :: Char -> Char + fixChar '_' = '-' + fixChar c = toLower c + +-- | Map all versions of Cabal package pname to Debian package dname. +-- Not really a debian package name, but the name of a cabal package +-- that maps to the debian package name we want. (Should this be a +-- SrcPkgName?) +mapCabal :: Monad m => PackageName -> String -> DebT m () +mapCabal pname dname = + debianNameMap %= Map.alter f pname + where + f :: Maybe VersionSplits -> Maybe VersionSplits + f Nothing = Just (makePackage dname) + f (Just sp) = error $ "mapCabal " ++ show pname ++ " " ++ show dname ++ ": - already mapped: " ++ show sp + +-- | Map versions less than ver of Cabal Package pname to Debian package ltname +splitCabal :: Monad m => PackageName -> String -> Version -> DebT m () +splitCabal pname ltname ver = + debianNameMap %= Map.alter f pname + where + f :: Maybe VersionSplits -> Maybe VersionSplits + f Nothing = error $ "splitCabal - not mapped: " ++ show pname + f (Just sp) = Just (insertSplit ver ltname sp) diff --git a/src/Debian/Debianize/Debianize.hs b/src/Debian/Debianize/Debianize.hs deleted file mode 100644 --- a/src/Debian/Debianize/Debianize.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# 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 - , runDebianize' - , debianize - , debianization - , writeDebianization - , describeDebianization - , compareDebianization - , validateDebianization - ) where - -import Control.Applicative ((<$>), (<*>), pure) -import Control.Exception as E (catch, throw) -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 (watchAtom) -import Debian.Debianize.Input (inputDebianization, inputCabalization, inputLicenseFile, inputMaintainer, inputChangeLog) -import Debian.Debianize.Options (options, compileArgs) -import Debian.Debianize.SubstVars (substvars) -import Debian.Debianize.Types (DebAction(..), Top(Top, unTop)) -import Debian.Debianize.Utility (withCurrentDirectory, foldEmpty, replaceFile, zipMaps, indent, read') -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.License (License(AllRightsReserved)) -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, withArgs) -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)) - --- | The main function for the cabal-debian executable. -cabalDebian :: Atoms -> IO () -cabalDebian defaultAtoms = - compileEnvironmentArgs defaultAtoms >>= - compileCommandlineArgs >>= \ atoms -> - case getL debAction atoms of - SubstVar debType -> substvars atoms debType - Debianize -> debianize (Top ".") return defaultAtoms - Usage -> do - progName <- getProgName - let info = unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: " - , "" - , " " ++ progName ++ " --maintainer 'Maintainer Name '." - , "" - , "This will read the package's cabal file and any existing debian/changelog file and" - , "deduce what it can about the debianization, then it will create or modify files in" - , "the debian subdirectory. Note that it will not remove any files in debian, and" - , "these could affect the operation of the debianization in unknown ways. For this" - , "reason I recommend either using a pristine unpacked directory each time, or else" - , "using a revision control system to revert the package to a known state before running." - , "The following additional options are available:" ] - putStrLn (usageInfo info options) - -compileEnvironmentArgs :: Atoms -> IO Atoms -compileEnvironmentArgs atoms0 = - (compileArgs <$> (read' (\ s -> error $ "compileEnvrionmentArgs: " ++ show s) <$> getEnv "CABALDEBIAN") <*> pure atoms0) `catchIOError` const (return atoms0) - -compileCommandlineArgs :: Atoms -> IO Atoms -compileCommandlineArgs atoms0 = compileArgs <$> getArgs <*> pure atoms0 - --- | 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] -> Atoms -> IO () -callDebianize args defaultAtoms = - withArgs args (debianize (Top ".") return defaultAtoms) - --- | 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 = - getEnv "HOME" >>= \ home -> - doesFileExist "debian/Debianize.hs" >>= \ exists -> - case exists of - False -> return False - True -> - let autobuilderd = "-i.:" ++ home ".autobuilder.d" in - putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ([autobuilderd, "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) - --- | 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 - --- | Call runDebianize with the given working directory. -runDebianize' :: Top -> [String] -> IO Bool -runDebianize' top args = withCurrentDirectory (unTop top) $ runDebianize args - --- | Depending on the options in @atoms@, either validate, describe, --- or write the generated debianization. -debianize :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO () -debianize top customize defaultAtoms = - debianization top customize defaultAtoms >>= \ atoms -> - if getL validate atoms - then inputDebianization top >>= \ old -> return (validateDebianization old atoms) - else if getL dryRun atoms - then inputDebianization top >>= \ old -> putStr ("Debianization (dry run):\n" ++ compareDebianization (ensureCopyright old) atoms) - else writeDebianization top atoms - where - ensureCopyright = modL copyright (maybe (Just (Left AllRightsReserved)) Just) - --- | 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 :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO Atoms -debianization top customize defaultAtoms = - do atoms <- compileEnvironmentArgs defaultAtoms >>= - compileCommandlineArgs >>= - customize >>= - inputCabalization top - log <- (Just <$> inputChangeLog top) `E.catch` (\ (_ :: IOError) -> return Nothing) - date <- getCurrentLocalRFC822Time - maint <- inputMaintainer atoms >>= maybe (error "Missing value for --maintainer") return - level <- getDebhelperCompatLevel - copyright <- withCurrentDirectory (unTop top) $ inputLicenseFile (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ unTop top) - (getL packageDescription atoms)) - return $ debianization' date copyright maint level log atoms - -debianization' :: String -- ^ current date - -> Maybe Text -- ^ copyright - -> NameAddr -- ^ maintainer - -> Maybe Int -- ^ Default standards version - -> Maybe ChangeLog - -> Atoms -- ^ Debianization specification - -> Atoms -- ^ New debianization -debianization' date copy maint level log deb = - finalizeDebianization $ - modL compat (maybe level Just) $ - modL changelog (maybe log Just) $ - setL sourcePriority (Just Optional) $ - setL sourceSection (Just (MainSection "haskell")) $ - setL watch (Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))) $ - modL copyright (maybe (finalizeCopyright copy) Just) $ - 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 - finalizeCopyright (Just x) = Just (Right x) - finalizeCopyright Nothing = Just (Left (Cabal.license pkgDesc)) - --- | 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 = - concat $ - [Debian.depends rels] ++ - concatMap (\ cab -> maybe [[[Rel (BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]]] - Set.toList - (Map.lookup cab (getL extraLibMap deb))) - (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc) } - pkgDesc = fromMaybe (error "addExtraLibDependencies: no PackageDescription") $ getL packageDescription deb - --- | Write the files of the debianization @d@ to the directory @top@. -writeDebianization :: Top -> Atoms -> IO () -writeDebianization top d = - withCurrentDirectory (unTop 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 -> () -validateDebianization old new = - case () of - _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion))) - | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource))) - | oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages))) - | True -> () - 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 deleted file mode 100644 --- a/src/Debian/Debianize/Dependencies.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# 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 - , debianName' - , debNameFromType - , getRulesHead - , filterMissing - , binaryPackageDeps - , binaryPackageConflicts - , binaryPackageProvides - , binaryPackageReplaces - ) 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) -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 (showVersion) -import Debian.Control -import Debian.Debianize.Atoms (Atoms, packageDescription, rulesHead, compiler, noProfilingLibrary, noDocumentationLibrary, - missingDependencies, debianNameMap, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap, - packageInfo, depends, conflicts, provides, replaces, control) -import Debian.Debianize.Bundled (ghcBuiltIn) -import Debian.Debianize.ControlFile as Debian (PackageType(..), SourceDebDescription(..)) -import Debian.Debianize.Types (PackageInfo(devDeb, profDeb, docDeb), DebType(..)) -import Debian.Debianize.Types.VersionSplits (VersionSplits, doSplits, packageRangesFromVersionSplits) -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 Relations - 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] -> [Relations] - fixDeps xs = concatMap (\ cab -> maybe [[[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]]] - 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"] ++ - concat (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"] ++ - concat (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 (adapt (getL execMap atoms) dep) -buildDependencies atoms dep = - case unboxDependency dep of - Just (Dependency _name _ranges) -> - concat (adapt (getL execMap atoms) dep) - Nothing -> - [] - -adapt :: Map.Map String Relations -> Dependency_ -> [Relations] -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.Rel (D.BinPkgName pkg) Nothing Nothing]]] - --- 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 -> [Relations] -- 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 modL execMap (Map.insert (PackageName " ++ show pkg ++ ") (BinPkgName \"\")" - s -> [[[D.Rel (D.BinPkgName s) Nothing Nothing]]] - _ -> [] - -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 (getL debianNameMap 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 - -debianName :: (PkgName name) => Atoms -> PackageType -> PackageIdentifier -> name -debianName atoms typ pkgDesc = debianName' (Map.lookup (pkgName pkgDesc) (getL debianNameMap atoms)) typ pkgDesc - --- | 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) => Maybe VersionSplits -> PackageType -> PackageIdentifier -> name -debianName' msplits typ pkgDesc = - case msplits of - Nothing -> mkPkgName pname typ - Just splits -> (\ s -> mkPkgName' s typ) $ doSplits splits version - where - -- def = mkPkgName pname typ - pname@(PackageName _) = 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 pkg typ = mkPkgName' (debianBaseName pkg) typ - -mkPkgName' :: PkgName name => String -> PackageType -> name -mkPkgName' base 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 - -debianBaseName :: PackageName -> String -debianBaseName (PackageName name) = - map (fixChar . toLower) name - where - -- Underscore is prohibited in debian package names. - fixChar :: Char -> Char - fixChar '_' = '-' - fixChar c = toLower c - -{- --- | 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)) - -binaryPackageReplaces :: BinPkgName -> Atoms -> [[Relation]] -binaryPackageReplaces b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL replaces atoms)) - -binaryPackageProvides :: BinPkgName -> Atoms -> [[Relation]] -binaryPackageProvides b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL provides atoms)) diff --git a/src/Debian/Debianize/Details.hs b/src/Debian/Debianize/Details.hs --- a/src/Debian/Debianize/Details.hs +++ b/src/Debian/Debianize/Details.hs @@ -4,42 +4,45 @@ , seereasonDefaultAtoms ) where -import Data.Lens.Lazy (modL, setL) -import Data.Map as Map (fromList) -import Data.Monoid (mempty) -import Data.Set as Set (insert) -import Debian.Relation (BinPkgName(BinPkgName)) import Data.Version (Version(Version)) -import Debian.Debianize (Atoms, missingDependencies, epochMap) -import Debian.Debianize.VersionSplits (mapCabal, splitCabal) +import Debian.Debianize.DebianName (mapCabal, splitCabal) +import Debian.Debianize.Types.Atoms as T (epochMap, missingDependencies) +import Debian.Debianize.Monad (DebT) +import Debian.Debianize.Prelude ((+=), (++=)) +import Debian.Relation (BinPkgName(BinPkgName)) import Distribution.Package (PackageName(PackageName)) -debianDefaultAtoms :: Atoms +debianDefaultAtoms :: Monad m => DebT m () debianDefaultAtoms = - setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . - splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . - mapCabal (PackageName "parsec") "parsec3" . - splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . - mapCabal (PackageName "QuickCheck") "quickcheck2" . - mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ - mempty + do T.epochMap ++= (PackageName "HaXml", 1) + T.epochMap ++= (PackageName "HTTP", 1) + mapCabal (PackageName "parsec") "parsec3" + splitCabal (PackageName "parsec") "parsec2" (Version [3] []) + mapCabal (PackageName "QuickCheck") "quickcheck2" + splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) + mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" -seereasonDefaultAtoms :: Atoms +seereasonDefaultAtoms :: Monad m => DebT m () seereasonDefaultAtoms = - modL missingDependencies (Set.insert (BinPkgName "libghc-happstack-authenticate-9-doc")) . + do debianDefaultAtoms - splitCabal (PackageName "clckwrks") "clckwrks-13" (Version [0, 14] []) . - splitCabal (PackageName "clckwrks") "clckwrks-14" (Version [0, 15] []) . - mapCabal (PackageName "clckwrks") "clckwrks" . - splitCabal (PackageName "blaze-html") "blaze-html-5" (Version [0, 6] []) . - mapCabal (PackageName "blaze-html") "blaze-html" . - splitCabal (PackageName "happstack-authenticate") "happstack-authenticate-9" (Version [0, 10] []) . - mapCabal (PackageName "happstack-authenticate") "happstack-authenticate" . - splitCabal (PackageName "http-types") "http-types-7" (Version [0, 8] []) . - mapCabal (PackageName "http-types") "http-types" . - splitCabal (PackageName "web-plugins") "web-plugins-1" (Version [0, 2] []) . - mapCabal (PackageName "web-plugins") "web-plugins" . - splitCabal (PackageName "case-insensitive") "case-insensitive-0" (Version [1] []) . - mapCabal (PackageName "case-insensitive") "case-insensitive" $ + missingDependencies += BinPkgName "libghc-happstack-authenticate-9-doc" - debianDefaultAtoms + mapCabal (PackageName "clckwrks") "clckwrks" + splitCabal (PackageName "clckwrks") "clckwrks-13" (Version [0, 14] []) + splitCabal (PackageName "clckwrks") "clckwrks-14" (Version [0, 15] []) + + mapCabal (PackageName "blaze-html") "blaze-html" + splitCabal (PackageName "blaze-html") "blaze-html-5" (Version [0, 6] []) + + mapCabal (PackageName "happstack-authenticate") "happstack-authenticate" + splitCabal (PackageName "happstack-authenticate") "happstack-authenticate-9" (Version [0, 10] []) + + mapCabal (PackageName "http-types") "http-types" + splitCabal (PackageName "http-types") "http-types-7" (Version [0, 8] []) + + mapCabal (PackageName "web-plugins") "web-plugins" + splitCabal (PackageName "web-plugins") "web-plugins-1" (Version [0, 2] []) + + mapCabal (PackageName "case-insensitive") "case-insensitive" + splitCabal (PackageName "case-insensitive") "case-insensitive-0" (Version [1] []) diff --git a/src/Debian/Debianize/Files.hs b/src/Debian/Debianize/Files.hs --- a/src/Debian/Debianize/Files.hs +++ b/src/Debian/Debianize/Files.hs @@ -2,163 +2,194 @@ -- written out. {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TupleSections #-} module Debian.Debianize.Files - ( toFileMap + ( debianizationFileMap ) where -import Data.Lens.Lazy (getL) +import Control.Applicative ((<$>)) +import Control.Monad.Trans (lift) +import Control.Monad.Writer (WriterT, execWriterT, tell) +import Data.Lens.Lazy (access, 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.Monoid ((<>), mempty) 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.Debianize.Goodies (makeRulesHead) +import Debian.Debianize.Monad (DebT) +import Debian.Debianize.Prelude (showDeps') +import qualified Debian.Debianize.Types.Atoms as T +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import qualified Debian.Debianize.Types.SourceDebDescription as S import Debian.Relation (Relations, BinPkgName(BinPkgName)) -import Prelude hiding (init, unlines, writeFile) +import Distribution.License (License(AllRightsReserved)) +import Prelude hiding (init, unlines, writeFile, log) +--import System.Directory (getCurrentDirectory) 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) +type FilesT m = WriterT [(FilePath, Text)] (DebT m) -watchFile :: Atoms -> [(FilePath, Text)] -watchFile deb = maybe [] (\ x -> [("debian/watch", x)]) (getL watch deb) +-- | 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.) -intermediates :: Atoms -> [(FilePath, Text)] -intermediates deb = Set.toList $ getL intermediateFiles deb +debianizationFileMap :: (Monad m, Functor m) => DebT m (Map FilePath Text) +debianizationFileMap = + fmap (Map.fromListWithKey (\ k a b -> error $ "Multiple values for " ++ k ++ ":\n " ++ show a ++ "\n" ++ show b)) $ execWriterT $ + do -- here <- liftIO getCurrentDirectory + tell =<< control + tell =<< changelog + tell =<< rules + tell =<< compat + tell =<< copyright + tell =<< sourceFormatFiles + tell =<< watchFile + tell =<< installs + tell =<< dirs + tell =<< init + tell =<< logrotate + tell =<< links + tell =<< postinstFiles + tell =<< postrmFiles + tell =<< preinstFiles + tell =<< prermFiles + tell =<< intermediates -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 +sourceFormatFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +sourceFormatFiles = + maybe [] (\ x -> [("debian/source/format", pack (show (pretty x)))]) <$> (lift $ access T.sourceFormat) + +watchFile :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +watchFile = maybe [] (\ x -> [("debian/watch", x)]) <$> (lift $ access T.watch) + +intermediates :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +intermediates = Set.toList <$> (lift $ access T.intermediateFiles) + +installs :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +installs = + (map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (src, dst) -> src <> " " <> dst) (Set.toList pairs))))) . Map.toList . mapKeys pathf) <$> (lift $ access T.install) 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 +dirs :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +dirs = + (map (\ (path, dirs') -> (path, pack (List.unlines (Set.toList dirs')))) . Map.toList . mapKeys pathf) <$> (lift $ access T.installDir) where pathf name = "debian" show (pretty name) ++ ".dirs" -init :: Atoms -> [(FilePath, Text)] -init deb = - Map.toList $ mapKeys pathf $ getL installInit deb +init :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +init = + (Map.toList . mapKeys pathf) <$> (lift $ access T.installInit) 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 +logrotate :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +logrotate = + (map (\ (path, stanzas) -> (path, Text.unlines (Set.toList stanzas))) . Map.toList . mapKeys pathf) <$> (lift $ access T.logrotateStanza) 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 +links :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +links = + (map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (loc, txt) -> loc ++ " " ++ txt) (Set.toList pairs))))) . Map.toList . mapKeys pathf) <$> (lift $ access T.link) where pathf name = "debian" show (pretty name) ++ ".links" -postinstFiles :: Atoms -> [(FilePath, Text)] -postinstFiles deb = - Map.toList $ mapKeys pathf $ getL postInst deb +postinstFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +postinstFiles = + (Map.toList . mapKeys pathf) <$> (lift $ access T.postInst) where pathf (BinPkgName name) = "debian" show (pretty name) ++ ".postinst" -postrmFiles :: Atoms -> [(FilePath, Text)] -postrmFiles deb = - Map.toList $ mapKeys pathf $ getL postRm deb +postrmFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +postrmFiles = + (Map.toList . mapKeys pathf) <$> (lift $ access T.postRm) where pathf name = "debian" show (pretty name) ++ ".postrm" -preinstFiles :: Atoms -> [(FilePath, Text)] -preinstFiles deb = - Map.toList $ mapKeys pathf $ getL preInst deb +preinstFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +preinstFiles = + (Map.toList . mapKeys pathf) <$> (lift $ access T.preInst) where pathf name = "debian" show (pretty name) ++ ".preinst" -prermFiles :: Atoms -> [(FilePath, Text)] -prermFiles deb = - Map.toList $ mapKeys pathf $ getL preRm deb +prermFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +prermFiles = + (Map.toList . mapKeys pathf) <$> (lift $ access T.preRm) 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 - is debhelper installed?") $ getL compat atoms) <> "\n")), - ("debian/copyright", either (\ x -> pack (show (pretty x))) id (fromMaybe (error ("No DebCopyright atom: " ++ show atoms)) $ 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 :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +rules = + do rh <- lift (access T.rulesHead) >>= maybe (lift makeRulesHead) return + rl <- (reverse . Set.toList) <$> lift (access T.rulesFragments) + return [("debian/rules", Text.unlines (rh : rl))] -rules :: Atoms -> Text -rules deb = Text.unlines (maybe (getRulesHead deb) id (getL rulesHead deb) : reverse (Set.toList (getL rulesFragments deb))) +changelog :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +changelog = + do log <- lift $ access T.changelog + return [("debian/changelog", pack (show (pretty (fromMaybe (error "No changelog in debianization") log))))] -controlFile :: SourceDebDescription -> Control' String +control :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +control = + do d <- lift $ access T.control + return [("debian/control", pack (show (pretty (controlFile d))))] + +compat :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +compat = + do text <- lift $ access T.compat + return [("debian/compat", pack (show (fromMaybe (error "Missing DebCompat atom - is debhelper installed?") $ text) <> "\n"))] + +copyright :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] +copyright = + do copyrt <- lift $ access T.copyright + license <- lift $ access T.license + licenseFile <- lift $ access T.licenseFile + return [("debian/copyright", case (licenseFile, copyrt, license) of + (Just x, _, _) -> x <> "\n" + (_, Just x, y) -> x <> "\n" <> maybe mempty (\ z -> pack ("License: " <> (show (pretty z)) <> "\n")) y + (_, _, Just x) -> pack ("License: " <> show (pretty x) <> "\n") + _ -> pack ("License: " <> show (pretty AllRightsReserved)))] + +controlFile :: S.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) ++ - mField "Standards-Version" (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)) + ([Field ("Source", " " ++ show (pretty (getL S.source src))), + Field ("Maintainer", " " <> show (pretty (getL S.maintainer src)))] ++ + lField "Uploaders" (getL S.uploaders src) ++ + (case getL S.dmUploadAllowed src of True -> [Field ("DM-Upload-Allowed", " yes")]; False -> []) ++ + mField "Priority" (getL S.priority src) ++ + mField "Section" (getL S.section src) ++ + depField "Build-Depends" (getL S.buildDepends src) ++ + depField "Build-Depends-Indep" (getL S.buildDependsIndep src) ++ + depField "Build-Conflicts" (getL S.buildConflicts src) ++ + depField "Build-Conflicts-Indep" (getL S.buildConflictsIndep src) ++ + mField "Standards-Version" (getL S.standardsVersion src) ++ + mField "Homepage" (getL S.homepage src) ++ + List.map vcsField (Set.toList (getL S.vcsFields src)) ++ + List.map xField (Set.toList (getL S.xFields src))) : + List.map binary (getL S.binaryPackages src)) } where - binary :: BinaryDebDescription -> Paragraph' String + binary :: B.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)))]) + ([Field ("Package", " " ++ show (pretty (getL B.package bin))), + Field ("Architecture", " " ++ show (pretty (getL B.architecture bin)))] ++ + mField "Section" (getL B.binarySection bin) ++ + mField "Priority" (getL B.binaryPriority bin) ++ + mField "Essential" (getL B.essential bin) ++ + relFields (getL B.relations bin) ++ + [Field ("Description", " " ++ (unpack . ensureDescription . fromMaybe mempty . getL B.description $ bin))]) where ensureDescription t = case Text.lines t of @@ -166,34 +197,33 @@ (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 "" + vcsField (S.VCSBrowser t) = Field ("Vcs-Browser", " " ++ unpack t) + vcsField (S.VCSArch t) = Field ("Vcs-Arch", " " ++ unpack t) + vcsField (S.VCSBzr t) = Field ("Vcs-Bzr", " " ++ unpack t) + vcsField (S.VCSCvs t) = Field ("Vcs-Cvs", " " ++ unpack t) + vcsField (S.VCSDarcs t) = Field ("Vcs-Darcs", " " ++ unpack t) + vcsField (S.VCSGit t) = Field ("Vcs-Git", " " ++ unpack t) + vcsField (S.VCSHg t) = Field ("Vcs-Hg", " " ++ unpack t) + vcsField (S.VCSMtn t) = Field ("Vcs-Mtn", " " ++ unpack t) + vcsField (S.VCSSvn t) = Field ("Vcs-Svn", " " ++ unpack t) + xField (S.XField dests tag t) = Field (unpack ("X" <> showDests dests <> "-" <> tag), unpack (" " <> t)) + showDests s = if member S.B s then "B" else "" <> + if member S.S s then "S" else "" <> + if member S.C s then "C" else "" -relFields :: PackageRelations -> [Field' [Char]] +relFields :: B.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 "Depends" (getL B.depends rels) ++ + depField "Recommends" (getL B.recommends rels) ++ + depField "Suggests" (getL B.suggests rels) ++ + depField "Pre-Depends" (getL B.preDepends rels) ++ + depField "Breaks" (getL B.breaks rels) ++ + depField "Conflicts" (getL B.conflicts rels) ++ + depField "Provides" (getL B.provides rels) ++ + depField "Replaces" (getL B.replaces rels) ++ + depField "Built-Using" (getL B.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 --- a/src/Debian/Debianize/Finalize.hs +++ b/src/Debian/Debianize/Finalize.hs @@ -1,299 +1,691 @@ --- | Convert a Debianization into a list of files that can then be --- written out. +-- | Compute the debianization of a cabal package. {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Debian.Debianize.Finalize - ( finalizeDebianization + ( debianization + , finalizeDebianization' -- external use deprecated - used in test script ) where +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Control.Monad as List (mapM_) +import Control.Monad.State (get, modify) +import Control.Monad.Trans (liftIO, MonadIO) import Data.ByteString.Lazy.UTF8 (fromString) -import Data.Char (toLower) +import Data.Char (isSpace, 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.Function (on) +import Data.Lens.Lazy (access, getL) +import Data.List as List (filter, intercalate, map, minimumBy, nub, unlines) +import Data.Map as Map (delete, elems, lookup, map, Map, toList, unionsWith) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Monoid ((<>)) +import Data.Set as Set (difference, filter, fromList, map, null, Set, singleton, toList, union, unions) +import qualified Data.Set as Set (member) +import Data.Set.Extra as Set (mapM_) 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, - utilsPackageNames, 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, binaryPackageProvides, binaryPackageReplaces, 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, log) -import System.FilePath ((), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName) +import Data.Version (showVersion, Version) +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Debianize.Bundled (ghcBuiltIn) +import Debian.Debianize.Changelog (dropFutureEntries) +import Debian.Debianize.DebianName (debianName, mkPkgName, mkPkgName') +import Debian.Debianize.Goodies (backupAtoms, describe, execAtoms, serverAtoms, siteAtoms, watchAtom) +import Debian.Debianize.Input (dataDir, inputCabalization, inputChangeLog, inputMaintainer) +import Debian.Debianize.Monad as Monad (Atoms, DebT) +import Debian.Debianize.Options (compileCommandlineArgs, compileEnvironmentArgs) +import Debian.Debianize.Prelude ((%=), (+++=), (+=), foldEmpty, fromEmpty, fromSingleton, (~=), (~?=)) +import Debian.Debianize.Types (Top) +import qualified Debian.Debianize.Types as T +import qualified Debian.Debianize.Types.Atoms as A +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import Debian.Debianize.VersionSplits (packageRangesFromVersionSplits) +import Debian.Orphans () +import Debian.Policy (getDebhelperCompatLevel, haskellMaintainer, PackageArchitectures(Any, All), PackagePriority(Optional), Section(..)) +import Debian.Relation (BinPkgName, BinPkgName(BinPkgName), Relation, Relation(Rel), Relations) +import qualified Debian.Relation as D (BinPkgName(BinPkgName), Relation(..), Relations, VersionReq(EEQ, GRE, LTE, SGR, SLT)) +import Debian.Release (parseReleaseName) +import Debian.Time (getCurrentLocalRFC822Time) +import Debian.Version (buildDebianVersion, DebianVersion, parseDebianVersion) +import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName(PackageName)) +import Distribution.PackageDescription (PackageDescription) +import Distribution.PackageDescription as Cabal (allBuildInfo, BuildInfo(buildTools, extraLibs, pkgconfigDepends), Executable(..), BuildInfo(..)) +import qualified Distribution.PackageDescription as Cabal (BuildInfo(buildable), Executable(buildInfo, exeName), PackageDescription(buildDepends, dataFiles, executables, library, package), PackageDescription(license)) +import Distribution.Version (anyVersion, asVersionIntervals, earlierVersion, foldVersionRange', fromVersionIntervals, intersectVersionRanges, isNoVersion, laterVersion, orEarlierVersion, orLaterVersion, toVersionIntervals, unionVersionRanges, VersionRange, withinVersion) +import Distribution.Version.Invert (invertVersionRange) +import Prelude hiding (init, log, map, unlines, unlines, writeFile) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ((<.>), (), makeRelative, splitFileName, takeDirectory, takeFileName) +import System.IO.Unsafe (unsafePerformIO) +import System.Process (readProcessWithExitCode) import Text.PrettyPrint.ANSI.Leijen (pretty) +-- | 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 :: Top -> DebT IO () -> DebT IO () -> DebT IO () +debianization top init customize = + do inputCabalization top + inputChangeLog top + inputMaintainer + init + compileEnvironmentArgs + compileCommandlineArgs + customize + finalizeDebianization' + +-- | Do some light IO and call finalizeDebianization. +finalizeDebianization' :: (MonadIO m, Functor m) => DebT m () +finalizeDebianization' = + do date <- liftIO getCurrentLocalRFC822Time + debhelperCompat <- liftIO getDebhelperCompatLevel + finalizeDebianization date debhelperCompat + access T.verbosity >>= \ vb -> when (vb >= 3) (get >>= liftIO . A.showAtoms) + -- | 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 atoms0 = - g $ finalizeAtoms $ makeUtilsPackage $ librarySpecs $ putBuildDeps $ f $ finalizeAtoms $ atoms0 +-- FIXME: we should be able to run this without a PackageDescription, change +-- paramter type to Maybe PackageDescription and propagate down thru code +finalizeDebianization :: (Monad m, Functor m) => String -> Maybe Int -> DebT m () +finalizeDebianization date debhelperCompat = + do addExtraLibDependencies + Just pkgDesc <- access T.packageDescription + T.watch ~?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc)) + T.sourceSection ~?= Just (MainSection "haskell") + T.sourcePriority ~?= Just Optional + T.compat ~?= debhelperCompat + finalizeChangelog date + finalizeControl + T.license ~?= Just (Cabal.license pkgDesc) + expandAtoms + -- Create the binary packages for the web sites, servers, backup packges, and other executables + access T.executable >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList + access T.backups >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList + access T.serverInfo >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList + access T.website >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList + putBuildDeps pkgDesc + librarySpecs pkgDesc + makeUtilsPackages pkgDesc + -- Sketchy - I think more things that need expanded could be generated by the code + -- executed since the last expandAtoms. Anyway, should be idempotent. + expandAtoms + -- Turn atoms related to priority, section, and description into debianization elements + finalizeDescriptions + +-- | Compute the final values of the BinaryDebDescription record +-- description fields from the cabal descriptions and the values that +-- have already been set. +finalizeDescriptions :: (Monad m, Functor m) => DebT m () +finalizeDescriptions = access T.binaryPackages >>= List.mapM_ finalizeDescription + +finalizeDescription :: (Monad m, Functor m) => B.BinaryDebDescription -> DebT m () +finalizeDescription bdd = + do let b = getL B.package bdd + cabDesc <- describe b + T.debianDescription b ~?= Just cabDesc + +-- | 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. +debianVersion :: Monad m => DebT m DebianVersion +debianVersion = + do pkgDesc <- access T.packageDescription >>= maybe (error "debianVersion: no PackageDescription") return + let pkgId = Cabal.package pkgDesc + epoch <- debianEpoch (pkgName pkgId) + debVer <- access T.debVersion + case debVer of + Just override + | override < parseDebianVersion (show (pretty (pkgVersion pkgId))) -> + error ("Version from --deb-version (" ++ show (pretty override) ++ + ") is older than hackage version (" ++ show (pretty (pkgVersion pkgId)) ++ + "), maybe you need to unpin this package?") + Just override -> return override + Nothing -> + do let ver = show (pretty (pkgVersion pkgId)) + rev <- get >>= return . getL T.revision >>= return . foldEmpty Nothing Just . fromMaybe "" + return $ buildDebianVersion epoch ver rev + +-- | Return the Debian epoch number assigned to the given cabal +-- package - the 1 in version numbers like 1:3.5-2. +debianEpoch :: Monad m => PackageName -> DebT m (Maybe Int) +debianEpoch name = get >>= return . Map.lookup name . getL T.epochMap + +-- | Compute and return the debian source package name, based on the +-- sourcePackageName if it was specified, and constructed from the +-- cabal name otherwise. +finalizeSourceName :: Monad m => DebT m () +finalizeSourceName = + do debName <- debianName B.Source' + T.sourcePackageName ~?= Just debName + +finalizeMaintainer :: Monad m => DebT m () +finalizeMaintainer = + T.maintainer ~?= Just haskellMaintainer + +finalizeControl :: Monad m => DebT m () +finalizeControl = + do finalizeSourceName + finalizeMaintainer + Just src <- access T.sourcePackageName + maint <- access T.maintainer >>= return . fromMaybe (error "No maintainer") + T.source ~= Just src + T.maintainer ~= Just maint + -- control %= (\ y -> y { D.source = Just src, D.maintainer = Just maint }) + +-- | Make sure there is a changelog entry with the version number and +-- source package name implied by the debianization. This means +-- either adding an entry or modifying the latest entry (if its +-- version number is the exact one in our debianization.) +finalizeChangelog :: Monad m => String -> DebT m () +finalizeChangelog date = + do finalizeSourceName + finalizeMaintainer + ver <- debianVersion + src <- access T.sourcePackageName + Just maint <- access T.maintainer + cmts <- access T.comments + T.changelog %= fmap (dropFutureEntries ver) + T.changelog %= fixLog src ver cmts maint where + -- Ensure that the package name is correct in the first log entry. + fixLog src ver cmts _maint (Just (ChangeLog (entry : older))) | logVersion entry == ver = + Just (ChangeLog (entry { logPackage = show (pretty src) + , logComments = logComments entry ++ "\n" ++ + (List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) (fromMaybe [] cmts)) + } : older)) + -- The newest log entry isn't exactly ver, build a new entry. + fixLog src ver cmts maint log = + Just (ChangeLog (Entry { logPackage = show (pretty src) + , logVersion = ver + , logDists = [parseReleaseName "unstable"] + , logUrgency = "low" + , logComments = List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) + (fromMaybe [["Debianization generated by cabal-debian"]] cmts) + , logWho = show (pretty maint) + , logDate = date } : maybe [] (\ (ChangeLog entries) -> entries) log)) - -- Create the binary packages for the web sites, servers, backup packges, and other executables - 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 - -- Turn atoms related to priority, section, and description into debianization elements - 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 +-- | 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 :: (Monad m, Functor m) => DebT m () +addExtraLibDependencies = + do pkgDesc <- access T.packageDescription >>= maybe (error "addExtraLibDependencies: no PackageDescription") return + devName <- debianName B.Development + libMap <- access T.extraLibMap + binNames <- List.map (getL B.package) <$> access T.binaryPackages + when (any (== devName) binNames) (T.depends devName %= \ deps -> deps ++ g pkgDesc libMap) + where + g :: PackageDescription -> Map String Relations -> Relations + g pkgDesc libMap = concatMap (devDep libMap) (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc) + devDep :: Map String Relations -> String -> Relations + devDep libMap cab = maybe [[Rel (BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]] id (Map.lookup cab libMap) -cabalExecBinaryPackage :: BinPkgName -> Atoms -> Atoms -cabalExecBinaryPackage b deb = - modL control (\ y -> y {binaryPackages = bin : binaryPackages y}) deb +putBuildDeps :: Monad m => PackageDescription -> DebT m () +putBuildDeps pkgDesc = + do deps <- debianBuildDeps pkgDesc + depsIndep <- debianBuildDepsIndep pkgDesc + T.buildDepends ~= deps + T.buildDependsIndep ~= depsIndep + +cabalExecBinaryPackage :: Monad m => BinPkgName -> DebT m () +cabalExecBinaryPackage b = + do T.packageType b ~?= Just B.Exec + T.binaryArchitectures b ~?= Just Any + T.binarySection b ~?= Just (MainSection "misc") + desc <- describe b + T.debianDescription b ~?= Just desc + binaryPackageRelations b B.Exec 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 (: []) (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}"] ++ binaryPackageProvides b deb - , replaces_ = [anyrel "${haskell:Replaces}"] ++ binaryPackageReplaces b deb - , builtUsing = [] - } +binaryPackageRelations :: Monad m => BinPkgName -> B.PackageType -> DebT m () +binaryPackageRelations b typ = + do edds <- access T.extraDevDeps + T.depends b %= \ rels -> [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++ + (if typ == B.Development then edds else []) ++ rels + T.recommends b ~= [anyrel "${haskell:Recommends}"] + T.suggests b ~= [anyrel "${haskell:Suggests}"] + T.preDepends b ~= [] + T.breaks b ~= [] + T.conflicts b %= \ rels -> [anyrel "${haskell:Conflicts}"] ++ rels + T.provides b %= \ rels -> [anyrel "${haskell:Provides}"] ++ rels + T.replaces b %= \ rels -> [anyrel "${haskell:Replaces}"] ++ rels + T.builtUsing b ~= [] --- 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 +librarySpecs :: Monad m => PackageDescription -> DebT m () +librarySpecs pkgDesc = + do debName <- debianName B.Documentation + let dev = isJust (Cabal.library pkgDesc) + doc <- get >>= return . (/= singleton True) . getL T.noDocumentationLibrary + prof <- get >>= return . (/= singleton True) . getL T.noProfilingLibrary + when dev (librarySpec Any B.Development) + when (dev && prof) (librarySpec Any B.Profiling) + when (dev && doc) + (do docSpecsParagraph + T.link +++= (debName, singleton ("/usr/share/doc" show (pretty debName) "html" cabal <.> "txt", + "/usr/lib/ghc-doc/hoogle" hoogle <.> "txt"))) 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 - } +docSpecsParagraph :: Monad m => DebT m () +docSpecsParagraph = + do b <- debianName B.Documentation + binaryPackageRelations b B.Development -- not sure why this isn't Documentation, but I think there's a "good" reason + T.packageType b ~?= Just B.Documentation + desc <- describe b + T.packageType b ~?= Just B.Documentation + T.binaryArchitectures b ~= Just All + T.binarySection b ~?= Just (MainSection "doc") + T.debianDescription b ~?= Just desc -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 - } +librarySpec :: Monad m => PackageArchitectures -> B.PackageType -> DebT m () +librarySpec arch typ = + do b <- debianName typ + binaryPackageRelations b B.Development + T.packageType b ~?= Just typ + desc <- describe b + T.packageType b ~?= Just typ + T.binaryArchitectures b ~?= Just arch + T.debianDescription b ~?= Just desc --- | 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 ps = fromMaybe (singleton (debianName deb Utilities (Cabal.package pkgDesc))) (getL utilsPackageNames deb) - deb' = Set.fold (h datas execs) deb ps in - -- deb' = setL packageDescription (Just pkgDesc) (makeUtilsAtoms p datas execs deb) in - Set.fold (g execs) deb' ps - -- modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb' +-- | Make sure all data and executable files are assigned to at least +-- one binary package and make sure all binary packages are in the +-- package list in the source deb description. If there are left over +-- files, assign them to the packages returned by the +-- utilsPackageNames lens, and make sure those packages are in the +-- source deb description. +makeUtilsPackages :: forall m. (Monad m, Functor m) => PackageDescription -> DebT m () +makeUtilsPackages pkgDesc = + do -- Files the cabal package expects to be installed + -- Files that are already assigned to any binary deb + installedDataMap <- Map.unionsWith Set.union + <$> (sequence [(Map.map (Set.map fst) <$> access T.install), + (Map.map (Set.map fst) <$> access T.installTo), + (Map.map (Set.map fst) <$> access T.installData)]) :: DebT m (Map BinPkgName (Set FilePath)) + installedExecMap <- Map.unionsWith Set.union + <$> (sequence [(Map.map (Set.map fst) <$> access T.installCabalExec), + (Map.map (Set.map fst) <$> access T.installCabalExecTo)]) :: DebT m (Map BinPkgName (Set String)) + + -- The names of cabal executables that go into eponymous debs + insExecPkg <- access T.executable >>= return . Set.map ename . Set.fromList . elems + + let installedData = Set.unions (Map.elems installedDataMap) + installedExec = Set.unions (Map.elems installedExecMap) + + let availableData = Set.union installedData (Set.fromList (Cabal.dataFiles pkgDesc)) :: Set FilePath + availableExec = Set.union installedExec (Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc)))) :: Set FilePath + + access T.utilsPackageNames >>= \ names -> + when (Set.null names) (debianName B.Utilities >>= \ name -> T.utilsPackageNames ~= singleton name) + utilsPackages <- access T.utilsPackageNames + + -- Files that are installed into packages other than the utils packages + let installedDataOther = Set.unions $ Map.elems $ foldr (Map.delete) installedDataMap (Set.toList utilsPackages) + installedExecOther = + Set.union (tr "insExecPkg: " insExecPkg) $ + Set.unions $ Map.elems $ foldr (Map.delete) (tr "installedExec: " installedExecMap) (Set.toList utilsPackages) + + -- Files that will be in utils packages + let utilsData = Set.difference availableData installedDataOther + utilsExec = Set.difference (tr "availableExec: " availableExec) (tr "installedExecOther: " installedExecOther) + -- Files that still need to be assigned to the utils packages + let utilsDataMissing = Set.difference utilsData installedData + utilsExecMissing = Set.difference utilsExec installedExec + -- If any files belong in the utils packages, make sure they exist + when (not (Set.null utilsData && Set.null utilsExec)) + (Set.mapM_ (\ p -> do -- This is really for all binary debs except the libraries - I'm not sure why + T.rulesFragments += (pack ("build" show (pretty p) ++ ":: build-ghc-stamp")) + T.binaryArchitectures p ~?= Just (if Set.null utilsExec then All else Any) + T.binarySection p ~?= Just (MainSection "misc") + binaryPackageRelations p B.Utilities) utilsPackages) + -- Add the unassigned files to the utils packages + Set.mapM_ (\ p -> Set.mapM_ (\ path -> T.installData +++= (p, singleton (path, path))) utilsDataMissing) utilsPackages + Set.mapM_ (\ p -> Set.mapM_ (\ name -> T.installCabalExec +++= (p, singleton (name, "usr/bin"))) (tr "utilsExecMissing: " utilsExecMissing)) utilsPackages where - h datas execs p deb' = setL packageDescription (Just pkgDesc) (makeUtilsAtoms p datas execs deb') - g execs p deb' = modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb' - 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 + ename i = + case A.sourceDir i of + (Nothing) -> A.execName i + (Just s) -> s A.execName i -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 +tr :: Show a => String -> a -> a +tr _label x = {- trace ("(trace " ++ _label ++ show x ++ ")") -} x + +expandAtoms :: Monad m => DebT m () +expandAtoms = + do builddir <- get >>= return . fromEmpty (singleton "dist-ghc/build") . getL T.buildDir + dDir <- access T.packageDescription >>= maybe (error "expandAtoms") (return . dataDir) + expandApacheSites + expandInstallCabalExecs (fromSingleton (error "no builddir") (\ xs -> error $ "multiple builddirs:" ++ show xs) builddir) + expandInstallCabalExecTo (fromSingleton (error "no builddir") (\ xs -> error $ "multiple builddirs:" ++ show xs) builddir) + expandInstallData dDir + expandInstallTo + expandFile + expandWebsite + expandServer + expandBackups + expandExecutable 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 + expandApacheSites :: Monad m => DebT m () + expandApacheSites = + do mp <- get >>= return . getL T.apacheSite + List.mapM_ expandApacheSite (Map.toList mp) + where + expandApacheSite (b, (dom, log, text)) = + do T.link +++= (b, singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom)) + T.installDir +++= (b, singleton log) + T.file +++= (b, singleton ("/etc/apache2/sites-available" dom, text)) -anyrel :: String -> [Relation] -anyrel x = anyrel' (BinPkgName x) + expandInstallCabalExecs :: Monad m => FilePath -> DebT m () + expandInstallCabalExecs builddir = + do mp <- get >>= return . getL T.installCabalExec + List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (name, dst) -> T.install +++= (b, singleton (builddir name name, dst))) pairs) (Map.toList mp) -anyrel' :: BinPkgName -> [Relation] -anyrel' x = [Rel x Nothing Nothing] + expandInstallCabalExecTo :: Monad m => FilePath -> DebT m () + expandInstallCabalExecTo builddir = + do mp <- get >>= return . getL T.installCabalExecTo + List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (n, d) -> T.rulesFragments += (Text.unlines + [ pack ("binary-fixup" show (pretty b)) <> "::" + , "\tinstall -Dps " <> pack (builddir n n) <> " " <> pack ("debian" show (pretty b) makeRelative "/" d) ])) pairs) (Map.toList mp) -finalizeAtoms :: Atoms -> Atoms -finalizeAtoms atoms | atoms == mempty = atoms -finalizeAtoms atoms = atoms <> finalizeAtoms (expandAtoms atoms) + expandInstallData :: Monad m => FilePath -> DebT m () + expandInstallData dDir = + do mp <- get >>= return . getL T.installData + List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (s, d) -> + if takeFileName s == takeFileName d + then T.install +++= (b, singleton (s, (dDir makeRelative "/" (takeDirectory d)))) + else T.installTo +++= (b, singleton (s, (dDir makeRelative "/" d)))) pairs) (Map.toList mp) -expandAtoms :: Atoms -> Atoms -expandAtoms old = - expandApacheSite . - expandInstallCabalExec . - expandInstallCabalExecTo . - expandInstallData . - expandInstallTo . - expandFile . - expandWebsite . - expandServer . - expandBackups . - expandExecutable $ - mempty + expandInstallTo :: Monad m => DebT m () + expandInstallTo = + do mp <- get >>= return . getL T.installTo + List.mapM_ (\ (p, pairs) -> Set.mapM_ (\ (s, d) -> T.rulesFragments += (Text.unlines + [ pack ("binary-fixup" show (pretty p)) <> "::" + , "\tinstall -Dp " <> pack s <> " " <> pack ("debian" show (pretty p) makeRelative "/" d) ])) pairs) (Map.toList mp) + + expandFile :: Monad m => DebT m () + expandFile = + do mp <- get >>= return . getL T.file + List.mapM_ (\ (p, pairs) -> Set.mapM_ (\ (path, s) -> + do let (destDir', destName') = splitFileName path + tmpDir = "debian/cabalInstall" show (md5 (fromString (unpack s))) + tmpPath = tmpDir destName' + T.intermediateFiles += (tmpPath, s) + T.install +++= (p, singleton (tmpPath, destDir'))) pairs) (Map.toList mp) + + expandWebsite :: Monad m => DebT m () + expandWebsite = + do mp <- get >>= return . getL T.website + List.mapM_ (\ (b, site) -> modify (siteAtoms b site)) (Map.toList mp) + + expandServer :: Monad m => DebT m () + expandServer = + do mp <- get >>= return . getL T.serverInfo + List.mapM_ (\ (b, x) -> modify (serverAtoms b x False)) (Map.toList mp) + + expandBackups :: Monad m => DebT m () + expandBackups = + do mp <- get >>= return . getL T.backups + List.mapM_ (\ (b, name) -> modify (backupAtoms b name)) (Map.toList mp) + + expandExecutable :: Monad m => DebT m () + expandExecutable = + do mp <- get >>= return . getL T.executable + List.mapM_ (\ (b, f) -> modify (execAtoms b f)) (Map.toList mp) + +data Dependency_ + = BuildDepends Dependency + | BuildTools Dependency + | PkgConfigDepends Dependency + | ExtraLibs Relations + 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 + +-- |Debian packages don't have per binary package build dependencies, +-- so we just gather them all up here. +allBuildDepends :: Monad m => [Dependency] -> [Dependency] -> [Dependency] -> [String] -> DebT m [Dependency_] +allBuildDepends buildDepends' buildTools' pkgconfigDepends' extraLibs' = + do atoms <- get + return $ nub $ List.map BuildDepends buildDepends' ++ + List.map BuildTools buildTools' ++ + List.map PkgConfigDepends pkgconfigDepends' ++ + [ExtraLibs (fixDeps atoms extraLibs')] 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) + fixDeps :: Atoms -> [String] -> Relations + fixDeps atoms xs = + concatMap (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]] + (Map.lookup cab (getL T.extraLibMap atoms))) xs - 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) +-- The haskell-cdbs package contains the hlibrary.mk file with +-- the rules for building haskell packages. +debianBuildDeps :: Monad m => PackageDescription -> DebT m D.Relations +debianBuildDeps pkgDesc = + do deb <- get + cDeps <- cabalDeps + let bDeps = getL T.buildDepends deb + prof = (/= singleton True) $ getL T.noProfilingLibrary deb + let xs = 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"] ++ + bDeps ++ + (if prof then [anyrel "ghc-prof"] else []) ++ + cDeps + filterMissing xs + where + cabalDeps = + do deps <- allBuildDepends + (Cabal.buildDepends pkgDesc ++ concatMap (Cabal.targetBuildDepends . Cabal.buildInfo) (Cabal.executables pkgDesc)) + (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) + (concatMap extraLibs . allBuildInfo $ pkgDesc) + mapM buildDependencies (List.filter (not . selfDependency (Cabal.package pkgDesc)) deps) >>= return . concat - 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 -Dps " <> 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) +debianBuildDepsIndep :: Monad m => PackageDescription -> DebT m D.Relations +debianBuildDepsIndep pkgDesc = + do doc <- get >>= return . (/= singleton True) . getL T.noDocumentationLibrary + bDeps <- get >>= return . getL T.buildDependsIndep + cDeps <- cabalDeps + let xs = if doc + then nub $ [anyrel "ghc-doc"] ++ bDeps ++ concat cDeps + else [] + filterMissing xs + where + cabalDeps = + do deps <- allBuildDepends + (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc) + let deps' = List.filter (not . selfDependency (Cabal.package pkgDesc)) deps + mapM docDependencies deps' +{- + cabalDeps deb = + concat . List.map (\ x -> evalDebM (docDependencies x) deb) + $ List.filter (not . selfDependency (Cabal.package pkgDesc)) + $ evalDebM + (allBuildDepends + (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc)) + deb +-} - 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) +-- | 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 :: Monad m => Dependency_ -> DebT m D.Relations +docDependencies (BuildDepends (Dependency name ranges)) = dependencies B.Documentation name ranges +docDependencies _ = return [] + +-- | 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 :: Monad m => Dependency_ -> DebT m D.Relations +buildDependencies (BuildDepends (Dependency name ranges)) = + do dev <- dependencies B.Development name ranges + prof <- dependencies B.Profiling name ranges + return $ dev ++ prof +buildDependencies dep@(ExtraLibs _) = + do mp <- get >>= return . getL T.execMap + return $ concat $ adapt mp dep +buildDependencies dep = + case unboxDependency dep of + Just (Dependency _name _ranges) -> + do mp <- get >>= return . getL T.execMap + return $ concat $ adapt mp dep + Nothing -> + return [] + +adapt :: Map.Map String Relations -> Dependency_ -> [Relations] +adapt mp (PkgConfigDepends (Dependency (PackageName pkg) _)) = + maybe (aptFile pkg) (: []) (Map.lookup pkg mp) +adapt mp (BuildTools (Dependency (PackageName pkg) _)) = + maybe (aptFile pkg) (: []) (Map.lookup pkg mp) +adapt _flags (ExtraLibs x) = [x] +adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [[[D.Rel (D.BinPkgName pkg) Nothing Nothing]]] + +-- 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 -> [Relations] -- 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 debian package containing the build tool " ++ pkg ++ + ", try using --exec-map " ++ pkg ++ "= or execMap " ++ show pkg ++ + " [[Rel (BinPkgName \"\") Nothing Nothing]]" + s -> [[[D.Rel (D.BinPkgName s) Nothing Nothing]]] + _ -> [] + +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 :: Monad m => B.PackageType -> PackageName -> VersionRange -> DebT m Relations +dependencies typ name cabalRange = + do atoms <- get + -- 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. + let alts = case Map.lookup name (getL T.debianNameMap 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' -> List.map (\ (n, r) -> (mkPkgName' n typ, r)) (packageRangesFromVersionSplits splits') + mapM convert alts >>= mapM (doBundled typ name) . convert' . canonical . Or . catMaybes + where + convert :: Monad m => (BinPkgName, VersionRange) -> DebT m (Maybe (Rels Relation)) + convert (dname, range) = + case isNoVersion range''' of + True -> return Nothing + False -> + foldVersionRange' + (return $ Rel' (D.Rel dname Nothing Nothing)) + (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.EEQ dv)) Nothing)) + (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.SGR dv)) Nothing)) + (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.SLT dv)) Nothing)) + (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.GRE dv)) Nothing)) + (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.LTE dv)) Nothing)) + (\ x y -> debianVersion' name x >>= \ dvx -> + debianVersion' name y >>= \ dvy -> + return $ And [Rel' (D.Rel dname (Just (D.GRE dvx)) Nothing), + Rel' (D.Rel dname (Just (D.SLT dvy)) Nothing)]) + (\ x y -> x >>= \ x' -> y >>= \ y' -> return $ Or [x', y']) + (\ x y -> x >>= \ x' -> y >>= \ y' -> return $ And [x', y']) + id + range''' >>= return . Just where - datadir = fromMaybe (error "finalizeAtoms: no dataDir") $ getL dataDir old + -- 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 + simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2] + -- Simplify a VersionRange + canon = fromVersionIntervals . toVersionIntervals - 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) +-- 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 :: Monad m => B.PackageType -> PackageName -> [D.Relation] -> DebT m [D.Relation] +doBundled typ name rels = + do comp <- access T.compiler >>= return . fromMaybe (error "no Compiler value") + case ghcBuiltIn comp name of + True -> return $ rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing] + False -> return rels + where + compilerPackageName B.Documentation = D.BinPkgName "ghc-doc" + compilerPackageName B.Profiling = D.BinPkgName "ghc-prof" + compilerPackageName B.Development = D.BinPkgName "ghc" + compilerPackageName _ = D.BinPkgName "ghc" -- whatevs - 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) +-- Convert a cabal version to a debian version, adding an epoch number if requested +debianVersion' :: Monad m => PackageName -> Version -> DebT m DebianVersion +debianVersion' name v = + do atoms <- get + return $ parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (getL T.epochMap atoms)) ++ showVersion v) - expandWebsite :: Atoms -> Atoms - expandWebsite new = foldWithKey siteAtoms new (getL website old) +data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel' {unRel :: a} deriving Show - expandServer :: Atoms -> Atoms - expandServer new = foldWithKey (\ b x atoms -> serverAtoms b x False atoms) new (getL serverInfo old) +convert' :: Rels a -> [[a]] +convert' = List.map (List.map unRel . unOr) . unAnd . canonical - expandBackups :: Atoms -> Atoms - expandBackups new = foldWithKey backupAtoms new (getL backups old) +-- | 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 . List.map Or $ sequence $ List.map (concat . List.map unOr . unAnd . canonical) $ rels - expandExecutable :: Atoms -> Atoms - expandExecutable new = foldWithKey execAtoms new (getL executable old) +filterMissing :: Monad m => [[Relation]] -> DebT m [[Relation]] +filterMissing rels = + get >>= \ atoms -> return $ + List.filter (/= []) (List.map (List.filter (\ (Rel name _ _) -> not (Set.member name (getL T.missingDependencies atoms)))) rels) diff --git a/src/Debian/Debianize/Goodies.hs b/src/Debian/Debianize/Goodies.hs --- a/src/Debian/Debianize/Goodies.hs +++ b/src/Debian/Debianize/Goodies.hs @@ -7,7 +7,6 @@ , doWebsite , doBackups , doExecutable - , debianDescription , describe , watchAtom , oldClckwrksSiteFlags @@ -16,29 +15,27 @@ , serverAtoms , backupAtoms , execAtoms + , makeRulesHead ) where -import Data.Lens.Lazy (getL, modL) +import Data.Lens.Lazy (modL, access) import Data.List as List (map, intersperse, intercalate) import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Set as Set (insert, union, singleton) import Data.Text as Text (Text, pack, unlines, intercalate) -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) -import Debian.Debianize.ControlFile as Debian (PackageType(..)) -import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..)) -import Debian.Debianize.Utility (trim) +import Debian.Debianize.DebianName (debianName) +import Debian.Debianize.Monad (Atoms, DebT, execDebM) +import Debian.Debianize.Prelude (trim, (%=), (+=), (++=), (+++=)) +import qualified Debian.Debianize.Types as T +import qualified Debian.Debianize.Types.Atoms as T +import qualified Debian.Debianize.Types.BinaryDebDescription as B 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.PackageDescription as Cabal (PackageDescription(package, synopsis, description, author, maintainer, pkgUrl)) import Distribution.Text (display) import Prelude hiding (writeFile, init, unlines, log, map) import System.FilePath (()) @@ -59,19 +56,18 @@ -- 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 $ +tightDependencyFixup :: Monad m => [(BinPkgName, BinPkgName)] -> BinPkgName -> DebT m () +tightDependencyFixup [] _ = return () +tightDependencyFixup pairs p = + T.rulesFragments += + (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 + [ "\techo '' >> debian/" <> name <> ".substvars" ])) 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" @@ -79,95 +75,92 @@ 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 (\ a b -> error $ "doExecutable: " ++ show (a, b)) bin x) deb +doExecutable :: Monad m => BinPkgName -> T.InstallFile -> DebT m () +doExecutable p f = T.executable ++= (p, f) -- | 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 (\ a b -> error $ "doServer: " ++ show (a, b)) bin x) deb +doServer :: Monad m => BinPkgName -> T.Server -> DebT m () +doServer p s = T.serverInfo ++= (p, s) -- | 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 (\ a b -> error $ "doWebsite: " ++ show (a, b)) bin x) deb +doWebsite :: Monad m => BinPkgName -> T.Site -> DebT m () +doWebsite p w = T.website ++= (p, w) -- | 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 +doBackups :: Monad m => BinPkgName -> String -> DebT m () +doBackups bin s = + do T.backups ++= (bin, s) + T.depends bin %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]]) + -- depends +++= (bin, Rel (BinPkgName "anacron") Nothing Nothing) -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 +describe :: Monad m => BinPkgName -> DebT m Text +describe b = + do Just p <- access T.packageDescription + typ <- access (T.packageType b) + return $ + debianDescriptionBase p <> "\n" <> + case typ of + Just B.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."] + Just B.Development -> + Text.intercalate "\n" + [" .", + " This package provides a library for the Haskell programming language.", + " See http:///www.haskell.org/ for more information on Haskell."] + Just B.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." ] + Just B.Exec -> + Text.intercalate "\n" + [" .", + " An executable built from the " <> pack (display (pkgName (Cabal.package p))) <> " package."] + {- ServerPackage -> + Text.intercalate "\n" + [" .", + " A server built from the " <> pack (display (pkgName pkgId)) <> " package."] -} + _ {-Utilities-} -> + Text.intercalate "\n" + [" .", + " Files associated with the " <> pack (display (pkgName (Cabal.package p))) <> " 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 +debianDescriptionBase :: PackageDescription -> Text +debianDescriptionBase p = + (pack . unwords . words $ Cabal.synopsis p) <> + case Cabal.description p of "" -> "" text -> let text' = text ++ "\n" ++ - list "" ("\n Author: " ++) author' ++ - list "" ("\n Upstream-Maintainer: " ++) maintainer' ++ - list "" ("\n Url: " ++) url in + list "" ("\n Author: " ++) (Cabal.author p) ++ + list "" ("\n Upstream-Maintainer: " ++) (Cabal.maintainer p) ++ + list "" ("\n Url: " ++) (Cabal.pkgUrl p) 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 :: T.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] + "--base-uri", "http://" ++ T.domain x ++ "/" + , "--http-port", show T.port] +oldClckwrksServerFlags :: T.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] + "--base-uri", "http://" ++ T.hostname x ++ ":" ++ show (T.port x) ++ "/" + , "--http-port", show T.port] watchAtom :: PackageName -> Text watchAtom (PackageName pkgname) = @@ -175,36 +168,38 @@ "-$1.tar.gz|\" \\\n http://hackage.haskell.org/package/" ++ pkgname ++ " \\\n ([\\d\\.]*\\d)/\n" -siteAtoms :: BinPkgName -> Site -> Atoms -> Atoms +-- FIXME - use Atoms +siteAtoms :: BinPkgName -> T.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 + execDebM + (do T.installDir +++= (b, singleton "/etc/apache2/sites-available") + T.link +++= (b, singleton ("/etc/apache2/sites-available/" ++ T.domain site, "/etc/apache2/sites-enabled/" ++ T.domain site)) + T.file +++= (b, singleton ("/etc/apache2/sites-available" T.domain site, apacheConfig)) + T.installDir +++= (b, singleton (apacheLogDirectory b)) + T.logrotateStanza +++= (b, singleton + (Text.unlines $ [ pack (apacheAccessLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}"])) + T.logrotateStanza +++= (b, singleton + (Text.unlines $ [ pack (apacheErrorLog b) <> " {" + , " weekly" + , " rotate 5" + , " compress" + , " missingok" + , "}" ]))) . + serverAtoms b (T.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) + , " ServerAdmin " <> pack (T.serverAdmin site) + , " ServerName www." <> pack (T.domain site) + , " ServerAlias " <> pack (T.domain site) , "" , " ErrorLog " <> pack (apacheErrorLog b) , " CustomLog " <> pack (apacheAccessLog b) <> " combined" @@ -233,33 +228,34 @@ , " ProxyPass / http://127.0.0.1:" <> port' <> "/ nocanon" , " ProxyPassReverse / http://127.0.0.1:" <> port' <> "/" , "" ] - port' = pack (show (port (server site))) + port' = pack (show (T.port (T.server site))) -serverAtoms :: BinPkgName -> Server -> Bool -> Atoms -> Atoms +-- FIXME - use Atoms +serverAtoms :: BinPkgName -> T.Server -> Bool -> Atoms -> Atoms serverAtoms b server' isSite = - modL postInst (insertWith (error "serverAtoms") b debianPostinst) . - modL installInit (Map.insertWith (error "serverAtoms") b debianInit) . + modL T.postInst (insertWith (\ old new -> if old /= new then error ("serverAtoms: " ++ show old ++ " -> " ++ show new) else old) b debianPostinst) . + modL T.installInit (Map.insertWith (\ old new -> if old /= new then error ("serverAtoms: " ++ show old ++ " -> " ++ show new) else old) b debianInit) . serverLogrotate' b . execAtoms b exec where - exec = installFile server' + exec = T.installFile server' debianInit = Text.unlines $ [ "#! /bin/sh -e" , "" , ". /lib/lsb/init-functions" - , "test -f /etc/default/" <> pack (destName exec) <> " && . /etc/default/" <> pack (destName exec) + , "test -f /etc/default/" <> pack (T.destName exec) <> " && . /etc/default/" <> pack (T.destName exec) , "" , "case \"$1\" in" , " start)" - , " test -x /usr/bin/" <> pack (destName exec) <> " || exit 0" - , " log_begin_msg \"Starting " <> pack (destName exec) <> "...\"" + , " test -x /usr/bin/" <> pack (T.destName exec) <> " || exit 0" + , " log_begin_msg \"Starting " <> pack (T.destName exec) <> "...\"" , " mkdir -p " <> pack (databaseDirectory b) , " " <> startCommand , " log_end_msg $?" , " ;;" , " stop)" - , " log_begin_msg \"Stopping " <> pack (destName exec) <> "...\"" + , " log_begin_msg \"Stopping " <> pack (T.destName exec) <> "...\"" , " " <> stopCommand , " log_end_msg $?" , " ;;" @@ -269,11 +265,11 @@ , "esac" , "" , "exit 0" ] - startCommand = pack $ showCommand "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverFlags server') + startCommand = pack $ showCommand "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ T.serverFlags server') stopCommand = pack $ showCommand "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 [] + commonOptions = ["--pidfile", "/var/run/" ++ T.destName exec] + startOptions = ["--start", "-b", "--make-pidfile", "-d", databaseDirectory b, "--exec", "/usr/bin" T.destName exec] + stopOptions = ["--stop", "--oknodo"] ++ if T.retry server' /= "" then ["--retry=" ++ T.retry server' ] else [] debianPostinst = Text.unlines $ @@ -300,24 +296,26 @@ -- | A configuration file for the logrotate facility, installed via a line -- in debianFiles. +-- FIXME - use Atoms serverLogrotate' :: BinPkgName -> Atoms -> Atoms serverLogrotate' b = - modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {" + modL T.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) <> " {" + modL T.logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {" , " weekly" , " rotate 5" , " compress" , " missingok" , "}" ]))) +-- FIXME - use Atoms backupAtoms :: BinPkgName -> String -> Atoms -> Atoms backupAtoms b name = - modL postInst (insertWith (error "backupAtoms") b + modL T.postInst (insertWith (\ old new -> if old /= new then error $ "backupAtoms: " ++ show old ++ " -> " ++ show new else old) b (Text.unlines $ [ "#!/bin/sh" , "" @@ -326,27 +324,42 @@ , " " <> pack ("/etc/cron.hourly" name) <> " --initialize" , " ;;" , "esac" ])) . - execAtoms b (InstallFile { execName = name - , destName = name - , sourceDir = Nothing - , destDir = Just "/etc/cron.hourly" }) + execAtoms b (T.InstallFile { T.execName = name + , T.destName = name + , T.sourceDir = Nothing + , T.destDir = Just "/etc/cron.hourly" }) -execAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms +-- FIXME - use Atoms +execAtoms :: BinPkgName -> T.InstallFile -> Atoms -> Atoms execAtoms b ifile r = - modL rulesFragments (Set.insert (pack ("build" show (pretty b) ++ ":: build-ghc-stamp"))) . + modL T.rulesFragments (Set.insert (pack ("build" show (pretty b) ++ ":: build-ghc-stamp"))) . fileAtoms b ifile $ r -fileAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms +-- FIXME - use Atoms +fileAtoms :: BinPkgName -> T.InstallFile -> Atoms -> Atoms fileAtoms b installFile' r = - fileAtoms' b (sourceDir installFile') (execName installFile') (destDir installFile') (destName installFile') r + fileAtoms' b (T.sourceDir installFile') (T.execName installFile') (T.destDir installFile') (T.destName installFile') r +-- FIXME - use Atoms 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 + (Nothing, True) -> modL T.installCabalExec (insertWith Set.union b (singleton (execName', d))) r + (Just s, True) -> modL T.install (insertWith Set.union b (singleton (s execName', d))) r + (Nothing, False) -> modL T.installCabalExecTo (insertWith Set.union b (singleton (execName', (d destName')))) r + (Just s, False) -> modL T.installTo (insertWith Set.union b (singleton (s execName', d destName'))) r where d = fromMaybe "usr/bin" destDir' + +-- | Build a suitable value for the head of the rules file. +makeRulesHead :: Monad m => DebT m Text +makeRulesHead = + do b <- debianName B.Cabal + let ls = ["DEB_CABAL_PACKAGE = " <> pack (show (pretty (b :: BinPkgName))), ""] + return $ + Text.unlines $ + ["#!/usr/bin/make -f", ""] ++ + ls ++ + ["include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk"] diff --git a/src/Debian/Debianize/Input.hs b/src/Debian/Debianize/Input.hs --- a/src/Debian/Debianize/Input.hs +++ b/src/Debian/Debianize/Input.hs @@ -5,41 +5,49 @@ ( inputDebianization , inputDebianizationFile , inputChangeLog + , inputCompiler + , inputCompiler' , inputCabalization - , inputLicenseFile + , inputCabalization' , inputMaintainer + , dataDir ) where import Debug.Trace (trace) +import Control.Category ((.)) import Control.Exception (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 Control.Monad.State (get, put) +import Control.Monad.Trans (MonadIO, liftIO, lift) +import Data.Char (isSpace, toLower) +import Data.Lens.Lazy (getL, setL, modL, access) +import Data.Maybe (fromMaybe) +import Data.Set as Set (Set, toList, fromList, insert, singleton) import Data.Text (Text, unpack, pack, lines, words, break, strip, null) import Data.Text.IO (readFile) -import Debian.Changes (ChangeLog(..), parseChangeLog) +import Data.Version (Version) +import Debian.Changes (ChangeLog(..), ChangeLogEntry(logWho), 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.Types (Top(Top, unTop)) -import Debian.Debianize.Utility (getDirectoryContents', withCurrentDirectory, readFileMaybe, read') +import qualified Debian.Debianize.Types as T (maintainer) +import qualified Debian.Debianize.Types.Atoms as T (changelog) +import Debian.Debianize.Types.BinaryDebDescription (BinaryDebDescription, newBinaryDebDescription) +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import qualified Debian.Debianize.Types.SourceDebDescription as S +import Debian.Debianize.Types.Atoms + (newAtoms, control, warning, sourceFormat, watch, rulesHead, compat, packageDescription, compiler, + license, licenseFile, copyright, changelog, installInit, postInst, postRm, preInst, preRm, + logrotateStanza, link, install, installDir, intermediateFiles, compilerVersion, cabalFlagAssignments, verbosity) +import Debian.Debianize.Monad (Atoms, DebT, execDebT) +import Debian.Debianize.Prelude (getDirectoryContents', withCurrentDirectory, readFileMaybe, read', intToVerbosity', (~=), (~?=), (+=), (++=), (+++=)) +import Debian.Debianize.Types.Base (Top(unTop)) import Debian.Orphans () import Debian.Policy (Section(..), parseStandardsVersion, readPriority, readSection, parsePackageArchitectures, parseMaintainer, - parseUploaders, readSourceFormat, getDebianMaintainer, haskellMaintainer) + parseUploaders, readSourceFormat, getDebianMaintainer) import Debian.Relation (Relations, BinPkgName(..), SrcPkgName(..), parseRelations) -import Distribution.Package (Package(packageId)) -import Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, maintainer)) +import Distribution.Package (Package(packageId), PackageIdentifier(..), PackageName(PackageName), Dependency) +import qualified Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, maintainer, package, license, copyright {-, synopsis, description-})) +import Distribution.PackageDescription as Cabal (PackageDescription, FlagName) import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..), Compiler(..)) @@ -47,75 +55,78 @@ 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 Distribution.Verbosity (Verbosity) +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) +import System.IO.Error (catchIOError, tryIOError) +-- import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) -inputDebianization :: Top -> IO Atoms +inputDebianization :: Top -> DebT IO () inputDebianization top = - do (ctl, _) <- inputSourceDebDescription top - atoms <- inputAtomsFromDirectory top mempty - return $ modL control (const ctl) atoms + do -- Erase any the existing information + put newAtoms + (ctl, _) <- inputSourceDebDescription top + inputAtomsFromDirectory top + control ~= ctl -- | Try to input a file and if successful add it to the debianization. -inputDebianizationFile :: Top -> FilePath -> Atoms -> IO Atoms -inputDebianizationFile (Top top) path atoms = - readFileMaybe (top path) >>= return . maybe atoms (\ text -> modL intermediateFiles (insert (path, text)) atoms) +inputDebianizationFile :: Top -> FilePath -> DebT IO () +inputDebianizationFile top path = + do inputAtomsFromDirectory top + lift (readFileMaybe (unTop top path)) >>= maybe (return ()) (\ text -> intermediateFiles += (path, text)) -inputSourceDebDescription :: Top -> IO (SourceDebDescription, [Field]) +inputSourceDebDescription :: Top -> DebT IO (S.SourceDebDescription, [Field]) inputSourceDebDescription top = - do paras <- parseControlFromFile (unTop top "debian/control") >>= either (error . show) (return . unControl) + do paras <- lift $ parseControlFromFile (unTop top "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' String -> [Paragraph' String] -> (S.SourceDebDescription, [Field]) parseSourceDebDescription (Paragraph fields) binaryParagraphs = foldr readField (src, []) fields' where fields' = map stripField fields - src = (newSourceDebDescription' findSource findMaint) {binaryPackages = bins} + src = setL S.binaryPackages bins (S.newSourceDebDescription' findSource findMaint) findSource = findMap "Source" SrcPkgName fields' findMaint = findMap "Maintainer" (\ m -> either (\ e -> error $ "Failed to parse maintainer field " ++ show m ++ ": " ++ show e) id . parseMaintainer $ m) fields' -- findStandards = findMap "Standards-Version" parseStandardsVersion fields' (bins, _extra) = unzip $ map parseBinaryDebDescription binaryParagraphs - readField :: Field -> (SourceDebDescription, [Field]) -> (SourceDebDescription, [Field]) + readField :: Field -> (S.SourceDebDescription, [Field]) -> (S.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) + readField (Field ("Standards-Version", value)) (desc, unrecognized) = (setL S.standardsVersion (Just (parseStandardsVersion value)) desc, unrecognized) + readField (Field ("Priority", value)) (desc, unrecognized) = (setL S.priority (Just (readPriority value)) desc, unrecognized) + readField (Field ("Section", value)) (desc, unrecognized) = (setL S.section (Just (MainSection value)) desc, 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 ("Homepage", value)) (desc, unrecognized) = (setL S.homepage (Just (strip (pack value))) desc, unrecognized) + readField (Field ("Uploaders", value)) (desc, unrecognized) = (setL S.uploaders (either (const []) id (parseUploaders value)) desc, unrecognized) + readField (Field ("DM-Upload-Allowed", value)) (desc, unrecognized) = (setL S.dmUploadAllowed (yes value) desc, unrecognized) + readField (Field ("Build-Depends", value)) (desc, unrecognized) = (setL S.buildDepends (rels value) desc, unrecognized) + readField (Field ("Build-Conflicts", value)) (desc, unrecognized) = (setL S.buildConflicts (rels value) desc, unrecognized) + readField (Field ("Build-Depends-Indep", value)) (desc, unrecognized) = (setL S.buildDependsIndep (rels value) desc, unrecognized) + readField (Field ("Build-Conflicts-Indep", value)) (desc, unrecognized) = (setL S.buildConflictsIndep (rels value) desc, unrecognized) + readField (Field ("Vcs-Browser", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSBrowser (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Arch", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSArch (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Bzr", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSBzr (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Cvs", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSCvs (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Darcs", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSDarcs (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Git", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSGit (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Hg", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSHg (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Mtn", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.VCSMtn (pack s)) vcsFields) desc, unrecognized) + readField (Field ("Vcs-Svn", s)) (desc, unrecognized) = (modL S.vcsFields (\ vcsFields -> insert (S.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' (\ s -> error $ "parseSourceDebDescription: " ++ show s) . (: [])) xs)) (pack more) (pack value)) (xFields desc)}, unrecognized) + (xs, '-' : more) -> (modL S.xFields (\ xFields -> insert (S.XField (fromList (map (read' (\ s -> error $ "parseSourceDebDescription: " ++ show s) . (: [])) xs)) (pack more) (pack value)) xFields) desc, unrecognized) _ -> (desc, field : unrecognized) readField field (desc, unrecognized) = (desc, field : unrecognized) @@ -124,9 +135,10 @@ foldr readField (bin, []) fields' where fields' = map stripField fields - bin = newBinaryDebDescription findPackage findArchitecture - findPackage = findMap "Package" BinPkgName fields' - findArchitecture = findMap "Architecture" parsePackageArchitectures fields' + bin = setL B.architecture (Just arch) (newBinaryDebDescription b) + b :: BinPkgName + b = findMap "Package" BinPkgName fields' + arch = findMap "Architecture" parsePackageArchitectures fields' {- (BinPkgName (fromJust (fieldValue "Package" bin))) (read' (fromJust (fieldValue "Architecture" bin))) @@ -135,21 +147,21 @@ -} 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 ("Package", x)) (desc, unrecognized) = (setL B.package (BinPkgName x) desc, unrecognized) + readField (Field ("Architecture", x)) (desc, unrecognized) = (setL B.architecture (Just (parsePackageArchitectures x)) desc, unrecognized) + readField (Field ("Section", x)) (desc, unrecognized) = (setL B.binarySection (Just (readSection x)) desc, unrecognized) + readField (Field ("Priority", x)) (desc, unrecognized) = (setL B.binaryPriority (Just (readPriority x)) desc, unrecognized) + readField (Field ("Essential", x)) (desc, unrecognized) = (setL B.essential (Just (yes x)) desc, unrecognized) + readField (Field ("Depends", x)) (desc, unrecognized) = (setL (B.depends . B.relations) (rels x) desc, unrecognized) + readField (Field ("Recommends", x)) (desc, unrecognized) = (setL (B.recommends . B.relations) (rels x) desc, unrecognized) + readField (Field ("Suggests", x)) (desc, unrecognized) = (setL (B.suggests . B.relations) (rels x) desc, unrecognized) + readField (Field ("Pre-Depends", x)) (desc, unrecognized) = (setL (B.preDepends . B.relations) (rels x) desc, unrecognized) + readField (Field ("Breaks", x)) (desc, unrecognized) = (setL (B.breaks . B.relations) (rels x) desc, unrecognized) + readField (Field ("Conflicts", x)) (desc, unrecognized) = (setL (B.conflicts . B.relations) (rels x) desc, unrecognized) + readField (Field ("Provides", x)) (desc, unrecognized) = (setL (B.provides . B.relations) (rels x) desc, unrecognized) + readField (Field ("Replaces", x)) (desc, unrecognized) = (setL (B.replaces . B.relations) (rels x) desc, unrecognized) + readField (Field ("Built-Using", x)) (desc, unrecognized) = (setL (B.builtUsing . B.relations) (rels x) desc, unrecognized) + readField (Field ("Description", x)) (desc, unrecognized) = (setL B.description (Just (pack x)) desc, unrecognized) readField field (desc, unrecognized) = (desc, field : unrecognized) -- | Look for a field and apply a function to its value @@ -173,46 +185,58 @@ yes "no" = False yes x = error $ "Expecting yes or no: " ++ x -inputChangeLog :: Top -> IO ChangeLog -inputChangeLog (Top top) = readFile (top "debian/changelog") >>= return . parseChangeLog . unpack +inputChangeLog :: MonadIO m => Top -> DebT m () +inputChangeLog top = + do log <- liftIO $ tryIOError (readFile (unTop top "debian/changelog") >>= return . parseChangeLog . unpack) + changelog ~?= either (\ _ -> Nothing) Just log -inputAtomsFromDirectory :: Top -> Atoms -> IO Atoms -- .install files, .init files, etc. -inputAtomsFromDirectory top xs = - findFiles xs >>= doFiles (unTop top "debian/cabalInstall") +inputAtomsFromDirectory :: Top -> DebT IO () -- .install files, .init files, etc. +inputAtomsFromDirectory top = + do atoms <- get + atoms' <- lift $ findFiles atoms + atoms'' <- lift $ doFiles (unTop top "debian/cabalInstall") atoms' + put atoms'' where + -- Find regular files matching debian/* and debian/source/format and + -- add them to the debianization. findFiles :: Atoms -> IO Atoms - findFiles xs' = + findFiles atoms = getDirectoryContents' (unTop top "debian") >>= return . (++ ["source/format"]) >>= filterM (doesFileExist . ((unTop top "debian") )) >>= - foldM (\ xs'' name -> inputAtoms (unTop top "debian") name xs'') xs' + foldM (\ atoms' name -> inputAtoms (unTop top "debian") name atoms') atoms doFiles :: FilePath -> Atoms -> IO Atoms - doFiles tmp xs' = + doFiles tmp atoms = do sums <- getDirectoryContents' tmp `catchIOError` (\ _ -> return []) paths <- mapM (\ sum -> getDirectoryContents' (tmp sum) >>= return . map (sum )) sums >>= return . filter ((/= '~') . last) . concat files <- mapM (readFile . (tmp )) paths - foldM (\ xs'' (path, file) -> return $ modL intermediateFiles (Set.insert ("debian/cabalInstall" path, file)) xs'') xs' (zip paths files) + execDebT (mapM_ (intermediateFiles +=) (zip (map ("debian/cabalInstall" ) paths) files)) atoms +-- | Construct a file path from the debian directory and a relative +-- path, read its contents and add the result to the debianization. +-- This may mean using a specialized parser from the debian package +-- (e.g. parseChangeLog), and some files (like control) are ignored +-- here, though I don't recall why at the moment. 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' (\ s -> error $ "compat: " ++ show s) (unpack text))) xs -inputAtoms debian name@"copyright" xs = readFile (debian name) >>= \ text -> return $ setL copyright (Just (Right text)) xs +inputAtoms debian name@"source/format" xs = readFile (debian name) >>= \ text -> execDebT (either (warning +=) ((sourceFormat ~=) . Just) (readSourceFormat text)) xs +inputAtoms debian name@"watch" xs = readFile (debian name) >>= \ text -> execDebT (watch ~= Just text) xs +inputAtoms debian name@"rules" xs = readFile (debian name) >>= \ text -> execDebT (rulesHead ~= (Just text)) xs +inputAtoms debian name@"compat" xs = readFile (debian name) >>= \ text -> execDebT (compat ~= Just (read' (\ s -> error $ "compat: " ++ show s) (unpack text))) xs +inputAtoms debian name@"copyright" xs = readFile (debian name) >>= \ text -> execDebT (copyright ~= Just text) xs inputAtoms debian name@"changelog" xs = - readFile (debian name) >>= return . parseChangeLog . unpack >>= \ log -> return $ setL changelog (Just log) xs + readFile (debian name) >>= return . parseChangeLog . unpack >>= \ log -> execDebT (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 + (p, ".install") -> readFile (debian name) >>= \ text -> execDebT (mapM_ (readInstall p) (lines text)) xs + (p, ".dirs") -> readFile (debian name) >>= \ text -> execDebT (mapM_ (readDir p) (lines text)) xs + (p, ".init") -> readFile (debian name) >>= \ text -> execDebT (installInit ++= (p, text)) xs + (p, ".logrotate") -> readFile (debian name) >>= \ text -> execDebT (logrotateStanza +++= (p, singleton text)) xs + (p, ".links") -> readFile (debian name) >>= \ text -> execDebT (mapM_ (readLink p) (lines text)) xs + (p, ".postinst") -> readFile (debian name) >>= \ text -> execDebT (postInst ++= (p, text)) xs + (p, ".postrm") -> readFile (debian name) >>= \ text -> execDebT (postRm ++= (p, text)) xs + (p, ".preinst") -> readFile (debian name) >>= \ text -> execDebT (preInst ++= (p, text)) xs + (p, ".prerm") -> readFile (debian name) >>= \ text -> execDebT (preRm ++= (p, text)) xs (_, ".log") -> return xs -- Generated by debhelper (_, ".debhelper") -> return xs -- Generated by debhelper (_, ".hs") -> return xs -- Code that uses this library @@ -222,42 +246,61 @@ (_, x) | last x == '~' -> return xs -- backup file _ -> trace ("Ignored: " ++ debian name) (return xs) -readLink :: BinPkgName -> Text -> Atoms -> Atoms -readLink p line atoms = +-- | Read a line from a debian .links file +readLink :: Monad m => BinPkgName -> Text -> DebT m () +readLink p line = case words line of - [a, b] -> modL link (insertWith Set.union p (singleton (unpack a, unpack b))) atoms - [] -> atoms - _ -> trace ("readLink: " ++ show line) atoms + [a, b] -> link +++= (p, singleton (unpack a, unpack b)) + [] -> return () + _ -> trace ("Unexpected value passed to readLink: " ++ show line) (return ()) -readInstall :: BinPkgName -> Text -> Atoms -> Atoms -readInstall p line atoms = +-- | Read a line from a debian .install file +readInstall :: Monad m => BinPkgName -> Text -> DebT m () +readInstall p line = 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 + (a, b) -> install +++= (p, singleton (unpack (strip a), unpack (strip b))) -readDir :: BinPkgName -> Text -> Atoms -> Atoms -readDir p line atoms = modL installDir (insertWith union p (singleton (unpack line))) atoms +-- | Read a line from a debian .dirs file +readDir :: Monad m => BinPkgName -> Text -> DebT m () +readDir p line = installDir +++= (p, singleton (unpack line)) -inputCabalization :: Top -> Atoms -> IO Atoms -inputCabalization top atoms = +inputCabalization :: MonadIO m => Top -> DebT m () +inputCabalization top = + do vb <- access verbosity >>= return . intToVerbosity' + comp <- inputCompiler top + compiler ~= Just comp + flags <- access cabalFlagAssignments + ePkgDesc <- liftIO $ inputCabalization' top vb comp flags + either (\ deps -> error $ "Missing dependencies in cabal package at " ++ show (unTop top) ++ ": " ++ show deps) + (\ pkgDesc -> do + packageDescription ~= Just pkgDesc + -- This will contain either the contents of the file given in + -- the license-file: field or the contents of the license: + -- field. + license ~?= (Just (Cabal.license pkgDesc)) + licenseFileText <- liftIO $ case Cabal.licenseFile pkgDesc of + "" -> return Nothing + path -> readFileMaybe (unTop top path) + licenseFile ~?= licenseFileText + copyright ~?= (case Cabal.copyright pkgDesc of + "" -> Nothing + s -> Just (pack s))) + ePkgDesc + +inputCabalization' :: Top -> Verbosity -> CompilerId -> Set (FlagName, Bool) -> IO (Either [Dependency] PackageDescription) +inputCabalization' top vb compId flags = withCurrentDirectory (unTop 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) + descPath <- defaultPackageDesc vb + genPkgDesc <- readPackageDescription vb descPath + case finalizePackageDescription (toList flags) (const True) (Platform buildArch buildOS) compId [] genPkgDesc of + Left deps -> return (Left deps) + Right (pkgDesc, _) -> + do bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc + return (Right pkgDesc) -- | Run the package's configuration script. -autoreconf :: Verbosity -> PackageDescription -> IO () +autoreconf :: Verbosity -> Cabal.PackageDescription -> IO () autoreconf verbose pkgDesc = do ac <- doesFileExist "configure.ac" when ac $ do @@ -269,26 +312,52 @@ 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. -inputLicenseFile :: PackageDescription -> IO (Maybe Text) -inputLicenseFile pkgDesc = readFileMaybe (licenseFile pkgDesc) +inputCompiler :: MonadIO m => Top -> DebT m CompilerId +inputCompiler top = + do vb <- access verbosity >>= return . intToVerbosity' + mCompilerVersion <- access compilerVersion + liftIO $ inputCompiler' top vb mCompilerVersion --- | 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) >>= - return . maybe (Just haskellMaintainer) 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)) +-- | Read the compiler version specified by Cabal, optionally +-- changing the version number. +inputCompiler' :: Top -> Verbosity -> Maybe Version -> IO CompilerId +inputCompiler' top vb mCompilerVersion = + withCurrentDirectory (unTop top) $ do + (Compiler {compilerId = CompilerId flavour version}, _) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration vb + return $ case mCompilerVersion of + Nothing -> CompilerId flavour version + Just version' -> CompilerId flavour version' -intToVerbosity' :: Int -> Verbosity -intToVerbosity' n = fromJust (intToVerbosity (max 0 (min 3 n))) +-- | Try to compute a string for the the debian "Maintainer:" field using, in this order +-- 1. the maintainer explicitly specified using "Debian.Debianize.Monad.maintainer" +-- 2. the maintainer field of the cabal package, +-- 3. the value returned by getDebianMaintainer, which looks in several environment variables, +-- 4. the signature from the latest entry in debian/changelog, +-- 5. the Debian Haskell Group, @pkg-haskell-maintainers\@lists.alioth.debian.org@ +inputMaintainer :: MonadIO m => DebT m () +inputMaintainer = + do Just pkgDesc <- access packageDescription + let cabalMaintainer = case Cabal.maintainer pkgDesc of + "" -> Nothing + x -> either (const Nothing) Just (parseMaintainer (takeWhile (\ c -> c /= ',' && c /= '\n') x)) + T.maintainer ~?= cabalMaintainer + debianMaintainer <- liftIO getDebianMaintainer + T.maintainer ~?= debianMaintainer + changelogMaintainer <- + do log <- get >>= return . getL T.changelog + case log of + Just (ChangeLog (entry : _)) -> + case (parseMaintainer (logWho entry)) of + Left _e -> return $ Nothing -- Just $ NameAddr (Just "Invalid signature in changelog") (show e) + Right x -> return (Just x) + _ -> return Nothing + T.maintainer ~?= changelogMaintainer + +-- | Compute the Cabal data directory for a Linux install from a Cabal +-- package description. This needs to match the path cabal assigns to +-- datadir in the dist/build/autogen/Paths_packagename.hs module, or +-- perhaps the path in the cabal_debian_datadir environment variable. +dataDir :: Cabal.PackageDescription -> FilePath +dataDir p = + let PackageName pkgname = pkgName . Cabal.package $ p in + "usr/share" map toLower pkgname diff --git a/src/Debian/Debianize/Monad.hs b/src/Debian/Debianize/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Monad.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Debian.Debianize.Monad + ( Atoms + + , DebT + , runDebT + , evalDebT + , execDebT + , DebM + , runDebM + , evalDebM + , execDebM + + -- * modify cabal to debian package version map + -- , mapCabal + -- , splitCabal + ) where + +import Control.Monad.State (evalState, evalStateT, execState, execStateT, runState, State, StateT(runStateT)) +import Data.Map as Map (alter) +import Data.Version (Version) +import Debian.Debianize.Types.Atoms (Atoms) +import Debian.Debianize.Types (debianNameMap) +import Debian.Debianize.Prelude ((%=)) +import Debian.Debianize.VersionSplits (insertSplit, makePackage, VersionSplits) +import Debian.Orphans () +import Distribution.Package (PackageName) +import Prelude hiding (init, log, unlines) + +type DebT m = StateT Atoms m +type DebM = State Atoms + +execDebT :: Monad m => DebT m a -> Atoms -> m Atoms +execDebT action atoms = execStateT action atoms + +evalDebT :: Monad m => DebT m a -> Atoms -> m a +evalDebT action atoms = evalStateT action atoms + +runDebT :: Monad m => DebT m a -> Atoms -> m (a, Atoms) +runDebT action atoms = runStateT action atoms + +execDebM :: DebM a -> Atoms -> Atoms +execDebM action atoms = execState action atoms + +evalDebM :: DebM a -> Atoms -> a +evalDebM action atoms = evalState action atoms + +runDebM :: DebM a -> Atoms -> (a, Atoms) +runDebM action atoms = runState action atoms diff --git a/src/Debian/Debianize/Options.hs b/src/Debian/Debianize/Options.hs --- a/src/Debian/Debianize/Options.hs +++ b/src/Debian/Debianize/Options.hs @@ -1,17 +1,26 @@ module Debian.Debianize.Options - ( compileArgs - , options + ( options + , compileArgs + , compileEnvironmentArgs + , compileCommandlineArgs + , putEnvironmentArgs + , withEnvironmentArgs ) where +import Control.Monad.State (lift) 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.Lens.Lazy (Lens) +import Data.Set (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.Debianize.Utility (read') +import Debian.Debianize.Types + (verbosity, dryRun, debAction, compilerVersion, noDocumentationLibrary, noProfilingLibrary, + missingDependencies, sourcePackageName, cabalFlagAssignments, maintainer, buildDir, omitLTDeps, + sourceFormat, buildDepends, buildDependsIndep, extraDevDeps, depends, conflicts, replaces, provides, + extraLibMap, debVersion, revision, epochMap, execMap) +import Debian.Debianize.Monad (DebT) +import Debian.Debianize.Prelude (read', maybeRead, (+=), (~=), (%=), (++=), (+++=)) +import Debian.Debianize.Types.Atoms (Atoms, InstallFile(..), DebAction(..)) import Debian.Orphans () import Debian.Policy (SourceFormat(Quilt3), parseMaintainer) import Debian.Relation (BinPkgName(..), SrcPkgName(..), Relations, Relation(..)) @@ -21,126 +30,150 @@ import Distribution.Package (PackageName(..)) import Prelude hiding (readFile, lines, null, log, sum) import System.Console.GetOpt (ArgDescr(..), OptDescr(..), ArgOrder(RequireOrder), getOpt') +import System.Environment (getArgs, getEnv) import System.FilePath ((), splitFileName) +import System.IO.Error (tryIOError) +import System.Posix.Env (setEnv) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Regex.TDFA ((=~)) -compileArgs :: [String] -> Atoms -> Atoms -compileArgs args atoms = +compileArgs :: [String] -> DebT IO () +compileArgs args = case getOpt' RequireOrder options args of - (os, [], [], []) -> foldl (flip ($)) atoms os + (os, [], [], []) -> sequence_ os (_, non, unk, errs) -> error ("Errors: " ++ show errs ++ ", Unrecognized: " ++ show unk ++ ", Non-Options: " ++ show non) +compileEnvironmentArgs :: DebT IO () +compileEnvironmentArgs = withEnvironmentArgs compileArgs + +compileCommandlineArgs :: DebT IO () +compileCommandlineArgs = lift getArgs >>= compileArgs + +-- | Read a value out of the CABALDEBIAN environment variable which is +-- the result of applying show to a [String]. +withEnvironmentArgs :: ([String] -> DebT IO a) -> DebT IO a +withEnvironmentArgs f = + lift (tryIOError (getEnv "CABALDEBIAN")) >>= either (\ _ -> f []) (maybe (f []) f . maybeRead) + +-- | 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 + -- | Options that modify other atoms. -options :: [OptDescr (Atoms -> Atoms)] +options :: [OptDescr (DebT IO ())] options = - [ Option "v" ["verbose"] (ReqArg (\ s atoms -> setL verbosity (read' (\ s' -> error $ "verbose: " ++ show s') s) atoms) "n") + [ Option "v" ["verbose"] (ReqArg (\ s -> verbosity ~= (read' (\ s' -> error $ "verbose: " ++ show s') s)) "n") "Change the amount of progress messages generated", - Option "n" ["dry-run", "compare"] (NoArg (\ atoms -> setL dryRun True atoms)) + Option "n" ["dry-run", "compare"] (NoArg (dryRun ~= True)) "Just compare the existing debianization to the one we would generate.", - Option "h?" ["help"] (NoArg (\ atoms -> setL debAction Usage atoms)) + Option "h?" ["help"] (NoArg (debAction ~= Usage)) "Show this help text", - Option "" ["executable"] (ReqArg (\ path x -> executableOption path (\ bin e -> doExecutable bin e x)) "SOURCEPATH or SOURCEPATH:DESTDIR") + Option "" ["executable"] (ReqArg (\ path -> executableOption path (\ bin e -> doExecutable bin e)) "SOURCEPATH or SOURCEPATH:DESTDIR") (unlines [ "Create an individual binary package to hold this executable. Other executables " , " and data files are gathered into a single utils package named 'haskell-packagename-utils'."]), - Option "" ["ghc-version"] (ReqArg (\ ver x -> setL compilerVersion (Just (last (map fst (readP_to_S parseVersion ver)))) x) "VERSION") + Option "" ["ghc-version"] (ReqArg (\ ver -> compilerVersion ~= Just (last (map fst (readP_to_S parseVersion ver)))) "VERSION") (unlines [ "Version of GHC in build environment. Without this option it is assumed that" , "the version of GHC in the build environment is the same as the one in the" , "environment in which cabal-debian is running. (the usual case.) The GHC" , "version is used to determine which packages are bundled with GHC - if a" , "package is bundled with GHC it is not necessary to add a build dependency for" , "that package to the debian/control file."]), - Option "" ["disable-haddock"] (NoArg (setL noDocumentationLibrary True)) + Option "" ["disable-haddock"] (NoArg (noDocumentationLibrary ~= singleton True)) (unlines [ "Don't generate API documentation packages, usually named" , "libghc-packagename-doc. Use this if your build is crashing due to a" , "haddock bug."]), - Option "" ["missing-dependency"] (ReqArg (\ name atoms -> modL missingDependencies (insert (BinPkgName name)) atoms) "DEB") + Option "" ["missing-dependency"] (ReqArg (\ name -> missingDependencies += (BinPkgName name)) "DEB") (unlines [ "This is the counterpart to --disable-haddock. It prevents a package" , "from being added to the build dependencies. This is necessary, for example," , "when a dependency package was built with the --disable-haddock option, because" , "normally cabal-debian assumes that the -doc package exists and adds it as a" , "build dependency."]), - Option "" ["source-package-name"] (ReqArg (\ name x -> setL sourcePackageName (Just (SrcPkgName name)) x) "NAME") + Option "" ["source-package-name"] (ReqArg (\ name -> sourcePackageName ~= (Just (SrcPkgName name))) "NAME") (unlines [ "Use this name for the debian source package, the name in the Source field at the top of the" , "debian control file, and also at the very beginning of the debian/changelog file. By default" , "this is haskell-, where the cabal package name is downcased."]), - Option "" ["disable-library-profiling"] (NoArg (setL noProfilingLibrary True)) + Option "" ["disable-library-profiling"] (NoArg (noProfilingLibrary ~= singleton True)) (unlines [ "Don't generate profiling (-prof) library packages. This has been used in one case" , "where the package code triggered a compiler bug."]), - Option "" ["maintainer"] (ReqArg (\ maint x -> setL maintainer (either (error ("Invalid maintainer string: " ++ show maint)) Just (parseMaintainer maint)) x) "Maintainer Name ") + Option "" ["maintainer"] (ReqArg (\ maint -> either (error ("Invalid maintainer string: " ++ show maint)) ((maintainer ~=) . Just) (parseMaintainer maint)) "Maintainer Name ") (unlines [ "Override the Maintainer name and email given in $DEBEMAIL or $EMAIL or $DEBFULLNAME or $FULLNAME"]), Option "" ["build-dep"] - (ReqArg (\ name atoms -> - modL buildDeps - (case parseRelations name of - Right rss -> Set.insert rss - Left err -> error ("cabal-debian option --build-dep " ++ show name ++ ": " ++ show err)) atoms) "Debian package relations") + (ReqArg (\ name -> + case parseRelations name of + Left err -> error ("cabal-debian option --build-dep " ++ show name ++ ": " ++ show err) + Right rss -> buildDepends %= (++ rss)) "Debian package relations") (unlines [ "Add a dependency relation to the Build-Depends: field for this source package, e.g." , "" , " --build-dep libglib2.0-dev" , " --build-dep 'libglib2.0-dev >= 2.2'" ]), Option "" ["build-dep-indep"] - (ReqArg (\ name atoms -> - modL buildDepsIndep - (case parseRelations name of - Right rss -> Set.insert rss - Left err -> error ("cabal-debian option --build-dep-indep " ++ show name ++ ": " ++ show err)) atoms) "Debian binary package name") + (ReqArg (\ name -> + case parseRelations name of + Left err -> error ("cabal-debian option --build-dep-indep " ++ show name ++ ": " ++ show err) + Right rss -> buildDependsIndep %= (++ rss)) "Debian binary package name") (unlines [ "Similar to --build-dep, but the dependencies are added to Build-Depends-Indep, e.g.:" , "" , " --build-dep-indep perl" ]), - Option "" ["dev-dep"] (ReqArg (\ name atoms -> modL extraDevDeps (Set.insert (Rel (BinPkgName name) Nothing Nothing)) atoms) "Debian binary package name") + Option "" ["dev-dep"] (ReqArg (\ name -> extraDevDeps %= (++ [[Rel (BinPkgName name) Nothing Nothing]])) "Debian binary package name") (unlines [ "Add an entry to the Depends: field 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,...") + Option "" ["depends"] + (ReqArg (addDep depends) "deb:deb,deb:deb,...") (unlines [ "Generalized --dev-dep - specify pairs A:B of debian binary package names, each" , "A gets a Depends: B. Note that B can have debian style version relations"]), - 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,...") + Option "" ["conflicts"] + (ReqArg (addDep conflicts) "deb:deb,deb:deb,...") "Like --depends, modifies the Conflicts field.", - Option "" ["replaces"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL replaces (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") + Option "" ["replaces"] + (ReqArg (addDep replaces) "deb:deb,deb:deb,...") "Like --depends, modifies the Replaces field.", - Option "" ["provides"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL provides (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") + Option "" ["provides"] + (ReqArg (addDep provides) "deb:deb,deb:deb,...") "Like --depends, modifies the Provides field.", - Option "" ["map-dep"] (ReqArg (\ pair atoms -> case break (== '=') pair of - (cab, (_ : deb)) -> modL extraLibMap (Map.insertWith Set.union cab (singleton (rels deb))) atoms - (_, "") -> error "usage: --map-dep CABALNAME=RELATIONS") "CABALNAME=RELATIONS") + Option "" ["map-dep"] (ReqArg (\ pair -> case break (== '=') pair of + (cab, (_ : deb)) -> extraLibMap +++= (cab, rels deb) + (_, "") -> error "usage: --map-dep CABALNAME=RELATIONS") "CABALNAME=RELATIONS") (unlines [ "Specify what debian package name corresponds with a name that appears in" , "the Extra-Library field of a cabal file, e.g. --map-dep cryptopp=libcrypto-dev." , "I think this information is present somewhere in the packaging system, but" , "I'm not sure of the details."]), - Option "" ["deb-version"] (ReqArg (\ version atoms -> setL debVersion (Just (parseDebianVersion version)) atoms) "VERSION") + Option "" ["deb-version"] (ReqArg (\ version -> debVersion ~= Just (parseDebianVersion version)) "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") + Option "" ["revision"] (ReqArg (\ rev -> revision ~= Just 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 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") + Option "" ["epoch-map"] + (ReqArg (\ pair -> case break (== '=') pair of + (_, (_ : ['0'])) -> return () + (cab, (_ : [d])) | isDigit d -> epochMap ++= (PackageName cab, ord d - ord '0') + _ -> 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 (rels deb)) atoms - _ -> error "usage: --exec-map EXECNAME=RELATIONS") "EXECNAME=RELATIONS") + Option "" ["exec-map"] (ReqArg (\ s -> case break (== '=') s of + (cab, (_ : deb)) -> execMap ++= (cab, rels deb) + _ -> error "usage: --exec-map EXECNAME=RELATIONS") "EXECNAME=RELATIONS") "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)) + Option "" ["omit-lt-deps"] (NoArg (omitLTDeps ~= singleton True)) (unlines [ "Remove all less-than dependencies from the generated control file. Less-than" , "dependencies are less useful and more troublesome for debian packages than cabal," , "because you can't install multiple versions of a given debian package. For more" , "google 'cabal hell'."]), - Option "" ["quilt"] (NoArg (setL sourceFormat (Just Quilt3))) + Option "" ["quilt"] (NoArg (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") + Option "" ["builddir"] (ReqArg (\ s -> buildDir ~= singleton (s "build")) "PATH") (unlines [ "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."]), - Option "f" ["flags"] (ReqArg (\ fs atoms -> modL cabalFlagAssignments (union (fromList (flagList fs))) atoms) "FLAGS") + Option "f" ["flags"] (ReqArg (\ fs -> mapM_ (cabalFlagAssignments +=) (flagList fs)) "FLAGS") (unlines [ "Flags to pass to the finalizePackageDescription function in" , "Distribution.PackageDescription.Configuration when loading the cabal file."]), - Option "" ["debianize"] (NoArg (\ atoms -> setL debAction Debianize atoms)) + Option "" ["debianize"] (NoArg (debAction ~= Debianize)) "Deprecated - formerly used to get what is now the normal benavior.", - Option "" ["substvar"] (ReqArg (\ name atoms -> setL debAction (SubstVar (read' (\ s -> error $ "substvar: " ++ show s) name)) atoms) "Doc, Prof, or Dev") + Option "" ["substvar"] (ReqArg (\ name -> debAction ~= (SubstVar (read' (\ s -> error $ "substvar: " ++ show s) name))) "Doc, Prof, or Dev") (unlines [ "With this option no debianization is generated. Instead, the list" , "of dependencies required for the dev, prof or doc package (depending" , "on the argument) is printed to standard output. These can be added" @@ -163,6 +196,9 @@ , sourceDir = case sd of "./" -> Nothing; _ -> Just sd , destDir = case md of (':' : dd) -> Just dd; _ -> Nothing }) +addDep :: Monad m => (BinPkgName -> Lens Atoms Relations) -> String -> DebT m () +addDep lns arg = mapM_ (\ (b, rel) -> lns b %= (++ [[rel]])) (parseDeps arg) + parseDeps :: String -> [(BinPkgName, Relation)] parseDeps arg = map pair (split arg) @@ -174,7 +210,7 @@ _ -> 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)) + (_, _, _, [x, y]) -> (BinPkgName x, anyrel (BinPkgName y)) _ -> error $ "Invalid dependency: " ++ show s -- Lifted from Distribution.Simple.Setup, since it's not exported. @@ -182,9 +218,6 @@ flagList = map tagWithValue . words where tagWithValue ('-':name) = (FlagName (map toLower name), False) tagWithValue name = (FlagName (map toLower name), True) - -b :: String -> BinPkgName -b = BinPkgName rels :: String -> Relations rels s = diff --git a/src/Debian/Debianize/Output.hs b/src/Debian/Debianize/Output.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Output.hs @@ -0,0 +1,138 @@ +-- | Wrappers around the debianization function to perform various +-- tasks - output, describe, validate a debianization, run an external +-- script to produce a debianization. + +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} + +module Debian.Debianize.Output + ( doDebianizeAction + , runDebianizeScript + , writeDebianization + , describeDebianization + , compareDebianization + , validateDebianization + ) where + +import Control.Category ((.)) +import Control.Exception as E (throw) +import Control.Monad.State (get, lift) +import Control.Monad.Trans (MonadIO) +import Data.Algorithm.Diff.Context (contextDiff) +import Data.Algorithm.Diff.Pretty (prettyDiff) +import Data.Lens.Lazy (getL) +import Data.Map as Map (elems, toList) +import Data.Maybe (fromMaybe) +import Data.Text as Text (split, Text, unpack) +import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) +import Debian.Debianize.Types (Top(unTop)) +import Debian.Debianize.Files (debianizationFileMap) +import Debian.Debianize.Input (inputDebianization) +import Debian.Debianize.Monad (DebT, Atoms, evalDebT) +import Debian.Debianize.Options (putEnvironmentArgs) +import Debian.Debianize.Prelude (indent, replaceFile, withCurrentDirectory, zipMaps) +import qualified Debian.Debianize.Types as T +import qualified Debian.Debianize.Types.BinaryDebDescription as B (package) +import qualified Debian.Debianize.Types.SourceDebDescription as S (source) +import Prelude hiding (unlines, writeFile, (.)) +import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions) +import System.Environment (getEnv) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ((), takeDirectory) +import System.Process (readProcessWithExitCode) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) + +-- | Run the script in @debian/Debianize.hs@ with the given command +-- line arguments. Returns @True@ if the script exists and succeeds. +-- In this case it may be assumed that a debianization was created (or +-- updated) in the debian subdirectory of the current directory. In +-- this way we can include a script in a package to produce a +-- customized debianization more sophisticated than the one that would +-- be produced by the cabal-debian executable. An example is included +-- in the debian subdirectory of this library. +runDebianizeScript :: [String] -> IO Bool +runDebianizeScript args = + getEnv "HOME" >>= \ home -> + doesFileExist "debian/Debianize.hs" >>= \ exists -> + case exists of + False -> return False + True -> + let autobuilderd = "-i.:" ++ home ".autobuilder.d" in + putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ([autobuilderd, "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) + +-- | Depending on the options in @atoms@, either validate, describe, +-- or write the generated debianization. +doDebianizeAction :: Top -> DebT IO () +doDebianizeAction top = + do new <- get + case () of + _ | getL T.validate new -> + do inputDebianization top + old <- get + return $ validateDebianization old new + _ | getL T.dryRun new -> + do inputDebianization top + old <- get + diff <- lift $ compareDebianization old new + lift $ putStr ("Debianization (dry run):\n" ++ diff) + _ -> writeDebianization top + +-- | Write the files of the debianization @d@ to the directory @top@. +writeDebianization :: Top -> DebT IO () +writeDebianization top = + do files <- debianizationFileMap + lift $ withCurrentDirectory (unTop top) $ mapM_ (uncurry doFile) (Map.toList files) + lift $ getPermissions (unTop top "debian/rules") >>= setPermissions (unTop top "debian/rules") . (\ p -> p {executable = True}) + where + doFile path text = + do createDirectoryIfMissing True (takeDirectory path) + replaceFile path (unpack text) + +-- | Return a string describing the debianization - a list of file +-- names and their contents in a somewhat human readable format. +describeDebianization :: (MonadIO m, Functor m) => DebT m String +describeDebianization = + debianizationFileMap >>= return . concatMap (\ (path, text) -> path ++ ": " ++ indent " > " (unpack text)) . Map.toList + +-- | Compare the old and new debianizations, returning a string +-- describing the differences. +compareDebianization :: Atoms -> Atoms -> IO String +compareDebianization old new = + do oldFiles <- evalDebT debianizationFileMap old + newFiles <- evalDebT debianizationFileMap new + return $ concat $ Map.elems $ zipMaps doFile oldFiles newFiles + 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" + +-- | Make sure the new debianization matches the existing +-- debianization in several ways - specifically, version number, and +-- the names of the source and binary packages. Some debian packages +-- come with a skeleton debianization that needs to be filled in, this +-- can be used to make sure the debianization we produce is usable. +validateDebianization :: Atoms -> Atoms -> () +validateDebianization old new = + case () of + _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion))) + | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource))) + | oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages))) + | True -> () + where + oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL T.changelog old)))) + newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL T.changelog new)))) + oldSource = getL (S.source . T.control) old + newSource = getL (S.source . T.control) new + oldPackages = map (getL B.package) $ getL T.binaryPackages old + newPackages = map (getL B.package) $ getL T.binaryPackages new + unChangeLog :: ChangeLog -> [ChangeLogEntry] + unChangeLog (ChangeLog x) = x diff --git a/src/Debian/Debianize/Prelude.hs b/src/Debian/Debianize/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Prelude.hs @@ -0,0 +1,327 @@ +-- | Functions and instances used by but not related to cabal-debian. +-- These could conceivably be moved into more general libraries. +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Debian.Debianize.Prelude + ( curry3 + , DebMap + , buildDebVersionMap + , (!) + , trim + , strictReadF + , replaceFile + , modifyFile + , diffFile + , removeIfExists + , dpkgFileMap + , debOfFile + , cond + , readFile' + , readFileMaybe + , showDeps + , showDeps' + , withCurrentDirectory + , getDirectoryContents' + , setMapMaybe + , zipMaps + , foldEmpty + , maybeL + , indent + , maybeRead + , read' + , modifyM + , intToVerbosity' + , (~=) + , (~?=) + , (%=) + , (+=) + , (++=) + , (+++=) + , fromEmpty + , fromSingleton + , Pretty(pretty) + ) where + +import Control.Applicative ((<$>)) +import Control.Exception as E (catch, try, bracket, IOException) +import Control.Monad (when) +import Control.Monad.Reader (ReaderT, ask) +import Control.Monad.State (MonadState, StateT, get, put) +import Data.Char (isSpace) +import qualified Data.Lens.Lazy as Lens ((~=), (%=)) +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, insertWith) +import Data.Maybe (catMaybes, mapMaybe, listToMaybe, fromMaybe, fromJust) +import Data.Monoid (Monoid, (<>), mappend) +import Data.Set as 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.Orphans () +import Debian.Version (DebianVersion, prettyDebianVersion) +import Debian.Version.String (parseDebianVersion) +import qualified Debian.Relation as D +import Distribution.Package (PackageIdentifier(..), PackageName(..)) +import Distribution.Verbosity (Verbosity, intToVerbosity) +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, catchIOError) +import System.Process (readProcessWithExitCode, showCommandForUser) +import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text) + +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 f a b c = f (a, b, c) + +type DebMap = Map D.BinPkgName (Maybe DebianVersion) + +-- | Read and parse the status file for installed debian packages: @/var/lib/dpkg/status@ +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 s = + 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 s + 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 s = + readProcessWithExitCode cmd args (unpack s) >>= \ (code, out, _err) -> + case code of + ExitSuccess -> return Nothing + ExitFailure 1 -> return (Just out) + _ -> error (showCommandForUser cmd args {- ++ " < " ++ show s -} ++ " -> " ++ 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 using the +-- contents of the debian package info directory @/var/lib/dpkg/info@. +dpkgFileMap :: IO (Map FilePath (Set D.BinPkgName)) +dpkgFileMap = + do + let fp = "/var/lib/dpkg/info" + names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list") + let paths = List.map (fp ) names + -- Read strictly to make sure we consume all the files and don't + -- hold tons of open file descriptors. + 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 FilePath (Set D.BinPkgName)) IO (Maybe D.BinPkgName) +debOfFile path = + do mp <- ask + return $ testPath (lookup path mp) + where + -- testPath :: Maybe (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 + +readFileMaybe :: FilePath -> IO (Maybe Text) +readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\ _ -> return Nothing) + +-- 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 - set the working directory and run an IO operation. +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 +-} + +-- | Get directory contents minus dot files. +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 s = unlines (List.map (prefix ++) (List.lines s)) + +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads + +read' :: Read a => (String -> a) -> String -> a +read' f s = fromMaybe (f s) (maybeRead s) + +-- modifyM :: (Monad m, MonadTrans t, MonadState a (t m)) => (a -> m a) -> t m () +-- modifyM f = get >>= lift . f >>= put + +-- modifyM :: (Monad m, MonadTrans t, MonadState a (t m)) => (a -> m a) -> t m () +modifyM :: MonadState a m => (a -> m a) -> m () +modifyM f = get >>= f >>= put + +-- read' :: Read a => String -> a +-- read' s = trace ("read " ++ show s) (read s) + +-- | Version of 'Distribution.Verbosity.intToVerbosity' that first +-- clamps its argument to the acceptable range (0-3). +intToVerbosity' :: Int -> Verbosity +intToVerbosity' n = fromJust (intToVerbosity (max 0 (min 3 n))) + +-- | Set a lens value. (This is a version of Data.Lens.Lazy.~= that returns () instead of b.) +(~=) :: Monad m => Lens a b -> b -> StateT a m () +lens ~= x = lens Lens.~= x >> return () + +-- | Set @b@ if it currently isNothing and the argument isJust, that is +-- 1. Nothing happens if the argument isNothing +-- 2. Nothing happens if the current value isJust +(~?=) :: Monad m => Lens a (Maybe b) -> Maybe b -> StateT a m () +lens ~?= (Just x) = lens Lens.%= maybe (Just x) Just >> return () +_ ~?= _ = return () + +-- | Modify a value. (This is a version of Data.Lens.Lazy.%= that returns () instead of a.) +(%=) :: Monad m => Lens a b -> (b -> b) -> StateT a m () +lens %= f = lens Lens.%= f >> return () + +-- | Insert an element into a @(Set b)@ +(+=) :: (Monad m, Ord b) => Lens a (Set b) -> b -> StateT a m () +lens += x = lens %= Set.insert x + +-- | Insert an element into a @(Map b c)@ +(++=) :: (Monad m, Ord b) => Lens a (Map b c) -> (b, c) -> StateT a m () +lens ++= (k, a) = lens %= Map.insert k a + +-- | Insert an element into a @(Map b (Set c))@ +(+++=) :: (Monad m, Ord b, Monoid c) => Lens a (Map b c) -> (b, c) -> StateT a m () +lens +++= (k, a) = lens %= Map.insertWith mappend k a + +fromEmpty :: Set a -> Set a -> Set a +fromEmpty d s | Set.null s = d +fromEmpty _ s = s + +fromSingleton :: a -> ([a] -> a) -> Set a -> a +fromSingleton e multiple s = + case toList s of + [x] -> x + [] -> e + xs -> multiple xs + +instance Pretty PackageIdentifier where + pretty p = pretty (pkgName p) <> text "-" <> pretty (pkgVersion p) + +instance Pretty PackageName where + pretty (PackageName s) = text s diff --git a/src/Debian/Debianize/SubstVars.hs b/src/Debian/Debianize/SubstVars.hs --- a/src/Debian/Debianize/SubstVars.hs +++ b/src/Debian/Debianize/SubstVars.hs @@ -7,27 +7,34 @@ ( substvars ) where +import Control.Applicative ((<$>)) 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 Control.Monad.State (get) +import Control.Monad.Trans (MonadIO, lift) +import Data.Lens.Lazy (getL, modL, access) +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, unlines) +import Data.List as List (map) +import qualified Data.Map as Map (insert, lookup, Map) +import Data.Maybe (catMaybes, listToMaybe, fromMaybe) +import qualified Data.Set as Set (member, 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 (Top(Top), 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 Debian.Control (Control'(unControl), ControlFunctions(lookupP, parseControl, stripWS), Field'(Field)) +import Debian.Debianize.Input (inputCompiler, inputCabalization) +import Debian.Debianize.Monad (DebT) +import Debian.Debianize.Prelude ((!), buildDebVersionMap, cond, DebMap, debOfFile, diffFile, dpkgFileMap, replaceFile, showDeps, modifyM) +import Debian.Debianize.Types (Top) +import qualified Debian.Debianize.Types.Atoms as T +import Debian.Orphans () +import Debian.Relation (BinPkgName(BinPkgName), Relation, Relations) +import qualified Debian.Relation as D (BinPkgName(BinPkgName), ParseRelations(parseRelations), Relation(Rel), Relations, VersionReq(GRE)) import Distribution.Package (Dependency(..), PackageName(PackageName)) -import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) +import Distribution.PackageDescription as Cabal (allBuildInfo, buildTools, extraLibs, PackageDescription(..), pkgconfigDepends) +import Distribution.Simple.Compiler (CompilerId(CompilerId)) import Distribution.Simple.Utils (die) import Distribution.Text (display) +import Prelude hiding (unlines) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (()) import Text.PrettyPrint.ANSI.Leijen (pretty) @@ -42,19 +49,22 @@ -- 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 (Top ".") 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 :: Top + -> T.DebType -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc + -> DebT IO () +substvars top debType = + do inputCabalization top + debVersions <- lift buildDebVersionMap + comp <- inputCompiler top + modifyM (lift . libPaths comp debVersions) + control <- lift $ readFile "debian/control" >>= either (error . show) return . parseControl "debian/control" + substvars' debType control -substvars' :: Atoms -> DebType -> Control' String -> IO () -substvars' atoms debType control = - case (missingBuildDeps, path) of +substvars' :: T.DebType -> Control' String -> DebT IO () +substvars' debType control = + get >>= return . getL T.packageInfo >>= \ info -> + cabalDependencies >>= \ cabalDeps -> + case (missingBuildDeps info cabalDeps, 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: @@ -64,37 +74,39 @@ -- 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) + do old <- lift $ readFile path' + deps <- debDeps debType control + new <- addDeps old deps + dry <- get >>= return . getL T.dryRun + lift (diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path')) + (\ diff -> if dry 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.") + lift $ 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 = + addDeps old deps = case partition (isPrefixOf "haskell:Depends=") (lines old) of - ([], other) -> unlines (("haskell:Depends=" ++ showDeps (filterMissing atoms deps)) : other) + ([], other) -> filterMissing deps >>= \ deps' -> return $ unlines (("haskell:Depends=" ++ showDeps deps') : other) (hdeps, more) -> case deps of - [] -> unlines (hdeps ++ more) - _ -> unlines (map (++ (", " ++ showDeps (filterMissing atoms deps))) hdeps ++ more) + [] -> return $ unlines (hdeps ++ more) + _ -> filterMissing deps >>= \ deps' -> return $ unlines (map (++ (", " ++ showDeps 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 = + missingBuildDeps info cabalDeps = 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 + case Map.lookup name info of + Just info' -> + let prof = maybe (T.devDeb info') Just (T.profDeb info') in + let doc = T.docDeb info' in catMaybes [prof, doc] - Nothing -> []) (cabalDependencies atoms)) in + Nothing -> []) cabalDeps) in filter (not . (`elem` buildDepNames) . fst) requiredDebs buildDepNames :: [D.BinPkgName] buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps) @@ -104,18 +116,16 @@ 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) +libPaths :: CompilerId -> DebMap -> T.Atoms -> IO T.Atoms +libPaths compiler@(CompilerId comp _) debVersions atoms = + do a <- getDirPaths "/usr/lib" + b <- getDirPaths ("/usr/lib/haskell-packages" display comp "lib") + -- Build a map from names of installed debs to version numbers + dpkgFileMap >>= runReaderT (foldM (packageInfo' compiler debVersions) atoms (a ++ b)) 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' :: CompilerId -> DebMap -> T.Atoms -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO T.Atoms packageInfo' compiler debVersions atoms (d, f) = case parseNameVersion f of Nothing -> return atoms @@ -125,14 +135,90 @@ case (break (== '-') (reverse s)) of (_a, "") -> Nothing (a, b) -> Just (reverse (tail b), reverse a) - cdir = display (compilerId compiler) + cdir = display 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 + return $ modL T.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 + (T.PackageInfo { T.cabalName = PackageName p + , T.devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev + , T.profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof + , T.docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) atoms + +data Dependency_ + = BuildDepends Dependency + | BuildTools Dependency + | PkgConfigDepends Dependency + | ExtraLibs Relations + 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 + +-- Make a list of the debian devel packages corresponding to cabal packages +-- which are build dependencies +debDeps :: (MonadIO m, Functor m) => T.DebType -> Control' String -> DebT m D.Relations +debDeps debType control = + do info <- get >>= return . getL T.packageInfo + cabalDeps <- cabalDependencies + return $ interdependencies ++ otherdependencies info cabalDeps + where + interdependencies = + case debType of + T.Prof -> maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) (debNameFromType control T.Dev) + _ -> [] + otherdependencies info cabalDeps = + catMaybes (map (\ (Dependency name _) -> + case Map.lookup name info of + Just p -> maybe Nothing + (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) + (case debType of + T.Dev -> T.devDeb p + T.Prof -> T.profDeb p + T.Doc -> T.docDeb p) + Nothing -> Nothing) cabalDeps) + +cabalDependencies :: (MonadIO m, Functor m) => DebT m [Dependency] +cabalDependencies = + do pkgDesc <- fromMaybe (error "cabalDependencies") <$> access T.packageDescription + atoms <- get + return $ catMaybes $ map unboxDependency $ + allBuildDepends atoms + (Cabal.buildDepends pkgDesc) + (concatMap buildTools . allBuildInfo $ pkgDesc) + (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) + (concatMap extraLibs . allBuildInfo $ pkgDesc) + +-- |Debian packages don't have per binary package build dependencies, +-- so we just gather them all up here. +allBuildDepends :: T.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] -> [Relations] + fixDeps xs = map (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]] + (Map.lookup cab (getL T.extraLibMap atoms))) xs + +-- | Given a control file and a DebType, look for the binary deb with +-- the corresponding suffix and return its name. +debNameFromType :: Control' String -> T.DebType -> Maybe BinPkgName +debNameFromType control debType = + case debType of + T.Dev -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-dev") debNames) + T.Prof -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-prof") debNames) + T.Doc -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-doc") debNames) + where + debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control)))) + +filterMissing :: Monad m => [[Relation]] -> DebT m [[Relation]] +filterMissing rels = + do missing <- get >>= return . getL T.missingDependencies + return $ filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name missing))) rels) diff --git a/src/Debian/Debianize/Tests.hs b/src/Debian/Debianize/Tests.hs --- a/src/Debian/Debianize/Tests.hs +++ b/src/Debian/Debianize/Tests.hs @@ -5,111 +5,126 @@ , main ) where +-- import Control.Monad.State (get, put) 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.Lens.Lazy (access, getL) import Data.List (sortBy) import Data.Map as Map (differenceWithKey, intersectionWithKey) -import qualified Data.Map as Map +import qualified Data.Map as Map (elems, Map, toList) 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 Data.Monoid ((<>), mconcat, mempty) +import Data.Set as Set (fromList, singleton, union) +import qualified Data.Text as T (intercalate, lines, pack, split, Text, unlines) import Data.Version (Version(Version)) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry) -import Debian.Debianize.Debianize (debianization) -import Debian.Debianize.Atoms as Atoms - (Atoms, rulesHead, compat, sourceFormat, changelog, control, missingDependencies, revision, - binaryArchitectures, copyright, debVersion, execMap, buildDeps, utilsPackageNames, description, - depends, installData, epochMap {-, sourcePackageName, install, buildDepsIndep-}) -import Debian.Debianize.ControlFile as Deb (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..)) -import Debian.Debianize.Dependencies (getRulesHead) -import Debian.Debianize.Files (toFileMap) -import Debian.Debianize.Finalize (finalizeDebianization) -import Debian.Debianize.Goodies (tightDependencyFixup, doExecutable, doWebsite, doServer, doBackups) -import Debian.Debianize.Input (inputChangeLog, inputDebianization, inputCabalization) -import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), Top(Top)) -import Debian.Debianize.VersionSplits (mapCabal, splitCabal) -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.Debianize.DebianName (mapCabal, splitCabal) +import Debian.Debianize.Files (debianizationFileMap) +import Debian.Debianize.Finalize (debianization, finalizeDebianization') +import Debian.Debianize.Goodies (doBackups, doExecutable, doServer, doWebsite, makeRulesHead, tightDependencyFixup) +import Debian.Debianize.Input (inputChangeLog, inputDebianization) +import Debian.Debianize.Monad (DebT, evalDebT, execDebM, execDebT) +import Debian.Debianize.Prelude ((%=), (+++=), (++=), (+=), (~=)) +import Debian.Debianize.Types as T +import Debian.Debianize.Types.Atoms as T +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import qualified Debian.Debianize.Types.SourceDebDescription as S +import Debian.Policy (databaseDirectory, PackageArchitectures(All), PackagePriority(Extra), parseMaintainer, Section(MainSection), SourceFormat(Native3), StandardsVersion(..), getDebhelperCompatLevel, getDebianStandardsVersion) +import Debian.Relation (BinPkgName(..), Relation(..), SrcPkgName(..), VersionReq(..)) import Debian.Release (ReleaseName(ReleaseName, relName)) -import Debian.Version (buildDebianVersion, parseDebianVersion) -import Distribution.License (License(BSD3)) +import Debian.Version (parseDebianVersion, buildDebianVersion) +import Distribution.License (License(..)) import Distribution.Package (PackageName(PackageName)) import Prelude hiding (log) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (()) import System.Process (readProcessWithExitCode) -import Test.HUnit +import Test.HUnit hiding ((~?=)) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) -import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty, text) +import Text.PrettyPrint.ANSI.Leijen (pretty, Pretty, text) -- | A suitable defaultAtoms value for the debian repository. -defaultAtoms :: Atoms +defaultAtoms :: Monad m => DebT m () defaultAtoms = - setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . - splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . - mapCabal (PackageName "parsec") "parsec3" . - splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . - mapCabal (PackageName "QuickCheck") "quickcheck2" . - mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ - mempty + do T.epochMap ++= (PackageName "HaXml", 1) + T.epochMap ++= (PackageName "HTTP", 1) + mapCabal (PackageName "parsec") "parsec3" + splitCabal (PackageName "parsec") "parsec2" (Version [3] []) + mapCabal (PackageName "QuickCheck") "quickcheck2" + splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) + mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" -- | 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 -> Maybe Int -> Maybe StandardsVersion -> Atoms +newDebianization :: Monad m => ChangeLog -> Maybe Int -> Maybe StandardsVersion -> DebT m () newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry" newDebianization (log@(ChangeLog (entry : _))) level standards = - setL changelog (Just log) $ - setL compat level $ - modL control (\ x -> x { source = Just (SrcPkgName (logPackage entry)) - , maintainer = (either error Just (parseMaintainer (logWho entry))) - , standardsVersion = standards }) $ - defaultAtoms + do T.changelog ~= Just log + T.compat ~= level + T.source ~= Just (SrcPkgName (logPackage entry)) + T.maintainer ~= either error Just (parseMaintainer (logWho entry)) + T.standardsVersion ~= standards newDebianization _ _ _ = error "Invalid changelog" -newDebianization' :: Maybe Int -> Maybe StandardsVersion -> Atoms -> Atoms -newDebianization' level standards atoms = - setL compat level . - modL control (\ x -> x { standardsVersion = standards }) $ atoms +newDebianization' :: Monad m => Maybe Int -> Maybe StandardsVersion -> DebT m () +newDebianization' level standards = + do T.compat ~= level + T.standardsVersion ~= standards tests :: Test -tests = TestLabel "Debianization Tests" (TestList [test1, test2, test3, test4, test5, test6, test7, test8, test9]) +tests = TestLabel "Debianization Tests" (TestList [-- 1 and 2 do not input a cabal package - we're not ready to + -- debianize without a cabal package. + {- test1 "test1", + test2 "test2", -} + test3 "test3", + test4 "test4 - test-data/clckwrks-dot-com", + test5 "test5 - test-data/creativeprompts", + test6 "test6 - test-data/artvaluereport2", + test7 "test7 - debian/Debianize.hs", + test8 "test8 - test-data/artvaluereport-data", + test9 "test9 - test-data/alex", + test10 "test10 - test-data/archive"]) -test1 :: Test -test1 = - TestLabel "test1" $ +test1 :: String -> Test +test1 label = + TestLabel label $ TestCase (do level <- getDebhelperCompatLevel standards <- getDebianStandardsVersion :: IO (Maybe StandardsVersion) - let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ - newDebianization (ChangeLog [testEntry]) level standards - assertEqual "test1" [] (diffDebianizations testDeb1 deb)) + deb <- execDebT + (do -- let top = Top "." + defaultAtoms + newDebianization (ChangeLog [testEntry]) level standards + license ~= Just BSD3 + -- inputCabalization top + finalizeDebianization') + newAtoms + diff <- diffDebianizations testDeb1 deb + assertEqual label [] diff) 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 (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))) + execDebM + (do defaultAtoms + newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1))) + rulesHead %= (const (Just (T.unlines $ + [ "#!/usr/bin/make -f" + , "" + , "include /usr/share/cdbs/1/rules/debhelper.mk" + , "include /usr/share/cdbs/1/class/hlibrary.mk" ]))) + compat ~= Just 9 -- This will change as new version of debhelper are released + license ~= Just BSD3 + T.source ~= Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}) + T.maintainer ~= Just (NameAddr (Just "David Fox") "dsf@seereason.com") + T.standardsVersion ~= Just (StandardsVersion 3 9 3 (Just 1)) -- This will change as new versions of debian-policy are released + T.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]]) + T.buildDependsIndep %= (++ [[Rel (BinPkgName "ghc-doc") Nothing Nothing]])) + newAtoms log = ChangeLog [Entry { logPackage = "haskell-cabal-debian" , logVersion = buildDebianVersion Nothing "2.6.2" Nothing , logDists = [ReleaseName {relName = "unstable"}] @@ -118,35 +133,43 @@ , logWho = "David Fox " , logDate = "Thu, 20 Dec 2012 06:49:25 -0800" }] -test2 :: Test -test2 = - TestLabel "test2" $ +test2 :: String -> Test +test2 label = + TestLabel label $ TestCase (do level <- getDebhelperCompatLevel standards <- getDebianStandardsVersion - let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ newDebianization (ChangeLog [testEntry]) level standards - assertEqual "test2" [] (diffDebianizations expect deb)) + deb <- execDebT + (do -- let top = Top "." + defaultAtoms + newDebianization (ChangeLog [testEntry]) level standards + license ~= Just BSD3 + -- inputCabalization top + finalizeDebianization') + newAtoms + diff <- diffDebianizations expect deb + assertEqual label [] diff) 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 (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))) + execDebM + (do defaultAtoms + newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1))) + rulesHead %= (const (Just (T.unlines $ + ["#!/usr/bin/make -f", + "", + "include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk"]))) + compat ~= Just 9 + license ~= Just BSD3 + T.source ~= Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}) + T.maintainer ~= Just (NameAddr {nameAddr_name = Just "David Fox", nameAddr_addr = "dsf@seereason.com"}) + T.standardsVersion ~= Just (StandardsVersion 3 9 3 (Just 1)) + T.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]]) + T.buildDependsIndep %= (++ [[Rel (BinPkgName "ghc-doc") Nothing Nothing]])) + newAtoms log = ChangeLog [Entry {logPackage = "haskell-cabal-debian", logVersion = Debian.Version.parseDebianVersion ("2.6.2" :: String), logDists = [ReleaseName {relName = "unstable"}], @@ -156,68 +179,160 @@ logWho = "David Fox ", logDate = "Thu, 20 Dec 2012 06:49:25 -0800"}] -test3 :: Test -test3 = - TestLabel "test3" $ - TestCase (do deb <- inputDebianization (Top "test-data/haskell-devscripts") - assertEqual "test3" [] (diffDebianizations testDeb2 deb)) +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" ])) + +test3 :: String -> Test +test3 label = + TestLabel label $ + TestCase (do let top = Top "test-data/haskell-devscripts" + deb <- execDebT (inputDebianization top) T.newAtoms + diff <- diffDebianizations testDeb2 deb + assertEqual label [] diff) 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 (Just 7) (Just (StandardsVersion 3 9 4 Nothing))) + execDebM + (do defaultAtoms + newDebianization log (Just 7) (Just (StandardsVersion 3 9 4 Nothing)) + T.sourceFormat ~= Just Native3 + T.rulesHead ~= Just (T.pack (unlines ["#!/usr/bin/make -f", + "# -*- makefile -*-", + "", + "# Uncomment this to turn on verbose mode.", + "#export DH_VERBOSE=1", + "", + "DEB_VERSION := $(shell dpkg-parsechangelog | egrep '^Version:' | cut -f 2 -d ' ')", + "", + "manpages = $(shell cat debian/manpages)", + "", + "%.1: %.pod", + "\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@", + "", + "%.1: %", + "\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@", + "", + ".PHONY: build", + "build: $(manpages)", + "", + "install-stamp:", + "\tdh install", + "", + ".PHONY: install", + "install: install-stamp", + "", + "binary-indep-stamp: install-stamp", + "\tdh binary-indep", + "\ttouch $@", + "", + ".PHONY: binary-indep", + "binary-indep: binary-indep-stamp", + "", + ".PHONY: binary-arch", + "binary-arch: install-stamp", + "", + ".PHONY: binary", + "binary: binary-indep-stamp", + "", + ".PHONY: clean", + "clean:", + "\tdh clean", + "\trm -f $(manpages)", + "", + ""])) + T.compat ~= Just 7 + T.copyright ~= Just "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" + T.source ~= Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"}) + T.maintainer ~= Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}) + T.uploaders ~= [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}] + T.sourcePriority ~= Just Extra + T.sourceSection ~= Just (MainSection "haskell") + T.buildDepends %= (++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]]) + T.buildDependsIndep %= (++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]]) + T.standardsVersion ~= Just (StandardsVersion 3 9 4 Nothing) + T.vcsFields %= Set.union (Set.fromList [ S.VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts" + , S.VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"]) + T.binaryArchitectures (BinPkgName "haskell-devscripts") ~= Just All + T.debianDescription (BinPkgName "haskell-devscripts") ~= + Just + (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."]) + T.depends (BinPkgName "haskell-devscripts") ~= + [ [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] ] +{- + control %= (\ y -> y { S.source = + , S.maintainer = Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}) + , S.uploaders = [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}] + , S.priority = Just Extra + , S.section = Just (MainSection "haskell") + , S.buildDepends = (S.buildDepends y) ++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]] + , S.buildDependsIndep = (S.buildDependsIndep y) ++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]] + , S.standardsVersion = Just (StandardsVersion 3 9 4 Nothing) + , S.vcsFields = Set.union (S.vcsFields y) (Set.fromList [ S.VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts" + , S.VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"]) + , S.binaryPackages = [S.BinaryDebDescription { B.package = BinPkgName {unBinPkgName = "haskell-devscripts"} + , B.architecture = All + , B.binarySection = Nothing + , B.binaryPriority = Nothing + , B.essential = False + , B.description = Just $ + (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."]) + , B.relations = + B.PackageRelations + { B.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] ] + , B.recommends = [] + , B.suggests = [] + , B.preDepends = [] + , B.breaks = [] + , B.conflicts = [] + , B.provides_ = [] + , B.replaces_ = [] + , B.builtUsing = [] }}]}) +-} + ) + T.newAtoms log = ChangeLog [Entry { logPackage = "haskell-devscripts" , logVersion = Debian.Version.parseDebianVersion ("0.8.13" :: String) , logDists = [ReleaseName {relName = "experimental"}] @@ -233,33 +348,50 @@ , logWho = "Joachim Breitner " , logDate = "Sat, 04 Feb 2012 10:50:33 +0100"}] -test4 :: Test -test4 = - TestLabel "test4" $ - TestCase (do old <- inputDebianization (Top "test-data/clckwrks-dot-com/output") - new <- debianization (Top "test-data/clckwrks-dot-com/input") (customize old) defaultAtoms - assertEqual "test4" [] (diffDebianizations old (copyFirstLogEntry old new))) +test4 :: String -> Test +test4 label = + TestLabel label $ + TestCase (do let inTop = Top "test-data/clckwrks-dot-com/input" + outTop = Top "test-data/clckwrks-dot-com/output" + old <- execDebT (inputDebianization outTop) T.newAtoms + let log = getL T.changelog old + new <- execDebT (debianization inTop defaultAtoms (customize log)) T.newAtoms + diff <- diffDebianizations old ({-copyFirstLogEntry old-} new) + assertEqual label [] diff) where - customize :: Atoms -> Atoms -> IO Atoms - customize old atoms = - inputCabalization (Top "test-data/clckwrks-dot-com/input") atoms >>= - return . - newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing)) . - 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" . + customize :: Maybe ChangeLog -> DebT IO () + customize log = + do T.changelog ~= log + tight + fixRules + doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups" + doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production")) + T.revision ~= Nothing + T.missingDependencies += (BinPkgName "libghc-clckwrks-theme-clckwrks-doc") + T.sourceFormat ~= Just Native3 + T.homepage ~= Just "http://www.clckwrks.com/" + newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing)) +{- + customize log = modifyM (lift . customize' log) + customize' :: Maybe ChangeLog -> Atoms -> IO Atoms + customize' log atoms = + execDebT (newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing))) . + modL T.control (\ y -> y {T.homepage = Just "http://www.clckwrks.com/"}) . + setL T.sourceFormat (Just Native3) . + modL T.missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) . + setL T.revision Nothing . + execDebM (doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production"))) . + execDebM (doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups") . fixRules . - tight . - setL changelog (getL changelog old) + execDebM tight . + setL T.changelog log +-} -- 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 + fixRules = + makeRulesHead >>= \ rh -> T.rulesHead %= (\ mt -> (Just . f) (fromMaybe rh mt)) where f t = T.unlines $ concat $ map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" @@ -276,16 +408,12 @@ 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 + tight = mapM_ (tightDependencyFixup [(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")]) serverNames - theSite :: BinPkgName -> Site + theSite :: BinPkgName -> T.Site theSite deb = Site { domain = hostname' , serverAdmin = "logic@seereason.com" @@ -330,44 +458,48 @@ anyrel :: BinPkgName -> Relation anyrel b = Rel b Nothing Nothing -test5 :: Test -test5 = - TestLabel "test5" $ - TestCase (do old <- inputDebianization (Top "test-data/creativeprompts/output") - let standards = standardsVersion (getL control old) - level = getL compat old - new <- debianization (Top "test-data/creativeprompts/input") - (return . - 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 utilsPackageNames (Just (singleton (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" [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) . - 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)) - defaultAtoms - assertEqual "test5" [] (diffDebianizations old (copyFirstLogEntry old new))) +test5 :: String -> Test +test5 label = + TestLabel label $ + TestCase (do let inTop = (Top "test-data/creativeprompts/input") + outTop = (Top "test-data/creativeprompts/output") + old <- execDebT (inputDebianization outTop) newAtoms + let standards = getL T.standardsVersion old + level = getL T.compat old + new <- execDebT (debianization inTop defaultAtoms (customize old level standards)) newAtoms + diff <- diffDebianizations old new + assertEqual label [] diff) where + customize old level standards = + do T.utilsPackageNames ~= singleton (BinPkgName "creativeprompts-data") + newDebianization' level standards + T.changelog ~= (getL T.changelog old) + doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production")) + doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development")) + doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups" + T.execMap ++= ("trhsx", [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) + mapM_ (\ b -> T.depends b %= \ deps -> deps ++ [[anyrel (BinPkgName "markdown")]]) + [(BinPkgName "creativeprompts-production"), (BinPkgName "creativeprompts-development")] + T.debianDescription (BinPkgName "creativeprompts-development") ~= + Just (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." ]) + T.debianDescription (BinPkgName "creativeprompts-data") ~= + Just (T.intercalate "\n" [ "creativeprompts.com data files" + , " Static data files for creativeprompts.com"]) + T.debianDescription (BinPkgName "creativeprompts-production") ~= + Just (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." ]) + T.debianDescription (BinPkgName "creativeprompts-backups") ~= + Just (T.intercalate "\n" [ "backup program for creativeprompts.com" + , " Install this somewhere other than creativeprompts.com to run automated" + , " backups of the database."]) + T.binaryArchitectures (BinPkgName "creativeprompts-production") ~= Just All + T.binaryArchitectures (BinPkgName "creativeprompts-data") ~= Just All + T.binaryArchitectures (BinPkgName "creativeprompts-development") ~= Just All + T.sourceFormat ~= Just Native3 + theSite :: BinPkgName -> Site theSite deb = Site { domain = hostname' @@ -410,76 +542,101 @@ 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" $ +test6 :: String -> Test +test6 label = + TestLabel label $ TestCase (do result <- readProcessWithExitCode "runhaskell" ["-isrc", "test-data/artvaluereport2/input/debian/Debianize.hs"] "" - assertEqual "test6" (ExitSuccess, "", "") result) + assertEqual label (ExitSuccess, "", "") result) -test7 :: Test -test7 = - TestLabel "test7" $ +test7 :: String -> Test +test7 label = + TestLabel label $ TestCase (do new <- readProcessWithExitCode "runhaskell" ["-isrc", "debian/Debianize.hs"] "" - assertEqual "test7" (ExitSuccess, "", "Ignored: ./debian/cabal-debian.1\nIgnored: ./debian/cabal-debian.manpages\n") new) + assertEqual label (ExitSuccess, "", "Ignored: ./debian/cabal-debian.1\nIgnored: ./debian/cabal-debian.manpages\n") new) -test8 :: Test -test8 = - TestLabel "test8" $ - TestCase ( do old <- inputDebianization (Top "test-data/artvaluereport-data/output") - log <- inputChangeLog (Top "test-data/artvaluereport-data/input") - new <- debianization (Top "test-data/artvaluereport-data/input") - (return . - modL buildDeps (Set.insert [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) . - modL control (\ y -> y {homepage = Just "http://artvaluereportonline.com"}) . - setL sourceFormat (Just Native3) . - setL changelog (Just log) . - (newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing)))) - defaultAtoms - assertEqual "test8" [] (diffDebianizations old (copyChangelog old new)) +test8 :: String -> Test +test8 label = + TestLabel label $ + TestCase ( do let inTop = Top "test-data/artvaluereport-data/input" + outTop = Top "test-data/artvaluereport-data/output" + old <- execDebT (inputDebianization outTop) newAtoms + log <- evalDebT (inputChangeLog inTop >> access T.changelog) newAtoms + new <- execDebT (debianization inTop defaultAtoms (customize log)) newAtoms + diff <- diffDebianizations old new + assertEqual label [] diff ) + where + customize Nothing = error "Missing changelog" + customize (Just log) = + do T.buildDepends %= (++ [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) + T.homepage ~= Just "http://artvaluereportonline.com" + T.sourceFormat ~= Just Native3 + T.changelog ~= Just log + newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing)) -test9 :: Test -test9 = - TestLabel "test9" $ - TestCase ( do old <- inputDebianization (Top "test-data/alex/output") - new <- debianization (Top "test-data/alex/input") - (return . - modL buildDeps (Set.insert [[Rel (BinPkgName "alex") Nothing Nothing]]) . - 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' (Just 7) (Just (StandardsVersion 3 9 3 Nothing))) - defaultAtoms - assertEqual "test9" [] (diffDebianizations old (copyFirstLogEntry old new))) +test9 :: String -> Test +test9 label = + TestLabel label $ + TestCase (do let inTop = Top "test-data/alex/input" + outTop = Top "test-data/alex/output" + old <- execDebT (inputDebianization outTop) newAtoms + let Just (ChangeLog (entry : _)) = getL T.changelog old + new <- execDebT (debianization inTop defaultAtoms customize >> copyChangelogDate (logDate entry)) newAtoms + diff <- diffDebianizations old new + assertEqual label [] diff) + where + customize = + do newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing)) + mapM_ (\ name -> T.installData +++= (BinPkgName "alex", singleton (name, name))) + [ "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"] + T.homepage ~= Just "http://www.haskell.org/alex/" + T.sourceFormat ~= Just Native3 + T.debVersion ~= Just (parseDebianVersion ("3.0.2-1~hackage1" :: String)) + doExecutable (BinPkgName "alex") + (InstallFile {execName = "alex", destName = "alex", sourceDir = Nothing, destDir = Nothing}) + -- Bootstrap dependency + T.buildDepends %= (++ [[Rel (BinPkgName "alex") Nothing Nothing]]) +test10 :: String -> Test +test10 label = + TestLabel label $ + TestCase (do let inTop = Top "test-data/archive/input" + outTop = Top "test-data/archive/output" + old <- execDebT (inputDebianization outTop) newAtoms + let Just (ChangeLog (entry : _)) = getL T.changelog old + new <- execDebT (debianization inTop defaultAtoms customize >> copyChangelogDate (logDate entry)) newAtoms + diff <- diffDebianizations old new + assertEqual label [] diff) + where + customize :: DebT IO () + customize = + do T.sourcePackageName ~= Just (SrcPkgName "seereason-darcs-backups") + T.compat ~= Just 5 + T.standardsVersion ~= Just (StandardsVersion 3 8 1 Nothing) + T.maintainer ~= either (const Nothing) Just (parseMaintainer "David Fox ") + T.depends (BinPkgName "seereason-darcs-backups") %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]]) + T.sourceSection ~= Just (MainSection "haskell") + T.utilsPackageNames += utils + T.installCabalExec +++= (utils, singleton ("seereason-darcs-backups", "/etc/cron.hourly")) + utils = BinPkgName "seereason-darcs-backups" + +copyChangelogDate :: Monad m => String -> DebT m () +copyChangelogDate date = + T.changelog %= (\ (Just (ChangeLog (entry : older))) -> Just (ChangeLog (entry {logDate = date} : older))) + data Change k a = Created k a | Deleted k a @@ -496,12 +653,12 @@ 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 :: Atoms -> Atoms -> IO String -- [Change FilePath T.Text] diffDebianizations old new = - show (mconcat (map prettyChange (filter (not . isUnchanged) (diffMaps old' new')))) + do old' <- evalDebT (sortBinaryDebs >> debianizationFileMap) old + new' <- evalDebT (sortBinaryDebs >> debianizationFileMap) new + return $ 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") @@ -520,17 +677,9 @@ -- 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" ])) +sortBinaryDebs :: DebT IO () +sortBinaryDebs = T.binaryPackages %= sortBy (compare `on` getL B.package) main :: IO () main = runTestTT tests >>= putStrLn . show diff --git a/src/Debian/Debianize/Types.hs b/src/Debian/Debianize/Types.hs --- a/src/Debian/Debianize/Types.hs +++ b/src/Debian/Debianize/Types.hs @@ -1,60 +1,260 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Debian.Debianize.Types ( Top(..) - , PackageInfo(..) - , Site(..) - , Server(..) - , InstallFile(..) - , DebType(..) - , DebAction(..) + -- * Modes of operation + , verbosity + , dryRun + , debAction + , cabalFlagAssignments + + -- * Cabal package info + , packageDescription + , compiler + + -- * Repository info + , execMap + , epochMap + , missingDependencies + , extraLibMap + , debianNameMap + + -- * Source Package Info + , sourcePackageName + , revision + , debVersion + , maintainer + , copyright + , license + , licenseFile + , sourceArchitectures + , sourcePriority + , sourceSection + , compat + , sourceFormat + , changelog + , comments + , standardsVersion + , rulesHead + , rulesFragments + , noProfilingLibrary + , noDocumentationLibrary + , utilsPackageNames + , buildDir + , watch + + -- * Source Package Build Dependencies + , omitLTDeps + , compilerVersion + + -- * Binary Package Info + , binaryArchitectures + , executable + , serverInfo -- askServers = serverInfo + , website + , backups + , apacheSite + , extraDevDeps + , postInst + , postRm + , preInst + , preRm + , binaryPriority + , binarySection + , installInit + , packageType + , debianDescription + , essential + + , relations + , depends + , recommends + , suggests + , preDepends + , breaks + , conflicts + , provides + , replaces + , builtUsing + +{- + -- * Binary Package Dependencies + , depends + , conflicts + , replaces + , provides +-} + + -- * Binary package Files + , link + , install + , installTo + , installData + , file + , installDir + , logrotateStanza + , installCabalExec + , installCabalExecTo + + -- * Unknown, obsolete, internal + , flags + , validate + , warning -- no-op? + , intermediateFiles + , packageInfo + , control -- obsolete + , source + , changedBy + , uploaders + , dmUploadAllowed + , homepage + , vcsFields + , xFields + , buildDepends + , buildConflicts + , buildDependsIndep + , buildConflictsIndep + , binaryPackages ) where +import Debian.Debianize.Types.Base +import Debian.Debianize.Types.Atoms +import Control.Category ((.)) +import Data.Lens.Lazy (Lens, lens, iso, getL) +import Data.Map as Map (Map) +import Data.Monoid (Monoid(..)) +import Data.Set as Set (Set) +import Data.Text (Text) +import Data.Version (Version) +import Debian.Changes (ChangeLog) +import Debian.Debianize.Types.Base (maybeLens, listElemLens) +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import qualified Debian.Debianize.Types.SourceDebDescription as S +import Debian.Debianize.VersionSplits (VersionSplits) import Debian.Orphans () -import Debian.Relation (BinPkgName) +import Debian.Policy (PackageArchitectures, PackagePriority, Section, SourceFormat, StandardsVersion) +import Debian.Relation (BinPkgName, Relations, SrcPkgName) import Debian.Version (DebianVersion) +import Distribution.License (License) import Distribution.Package (PackageName) -import Prelude hiding (init, unlines, log) +import Distribution.PackageDescription as Cabal (FlagName, PackageDescription) +import Distribution.Simple.Compiler (CompilerId) +import Prelude hiding (init, init, log, log, unlines, (.)) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) -newtype Top = Top {unTop :: FilePath} +binaryDebDescription :: BinPkgName -> Lens Atoms B.BinaryDebDescription +binaryDebDescription b = maybeLens (B.newBinaryDebDescription b) (iso id id) . listElemLens ((== b) . getL B.package) . S.binaryPackages . control -data PackageInfo = PackageInfo { cabalName :: PackageName - , devDeb :: Maybe (BinPkgName, DebianVersion) - , profDeb :: Maybe (BinPkgName, DebianVersion) - , docDeb :: Maybe (BinPkgName, DebianVersion) } deriving (Eq, Ord, Show) +packageType :: BinPkgName -> Lens Atoms (Maybe B.PackageType) +packageType b = B.packageType . binaryDebDescription b --- | 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) +-- | Lens into the description field of a BinaryDebDescription. +debianDescription :: BinPkgName -> Lens Atoms (Maybe Text) +debianDescription b = B.description . binaryDebDescription b --- | 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) +essential :: BinPkgName -> Lens Atoms (Maybe Bool) +essential b = B.essential . binaryDebDescription b -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) +relations :: BinPkgName -> Lens Atoms B.PackageRelations +relations b = B.relations . binaryDebDescription b -data DebAction = Usage | Debianize | SubstVar DebType deriving (Read, Show, Eq, Ord) +-- | The Depends: relations for each binary deb. +depends :: BinPkgName -> Lens Atoms Relations +depends b = B.depends . B.relations . binaryDebDescription b --- | A redundant data type, too lazy to expunge. -data DebType = Dev | Prof | Doc deriving (Eq, Ord, Read, Show) +-- | The Recommends: relations for each binary deb. +recommends :: BinPkgName -> Lens Atoms Relations +recommends b = B.recommends . B.relations . binaryDebDescription b + +-- | The Suggests: relations for each binary deb. +suggests :: BinPkgName -> Lens Atoms Relations +suggests b = B.suggests . B.relations . binaryDebDescription b + +-- | The Pre-Depends: relations for each binary deb. +preDepends :: BinPkgName -> Lens Atoms Relations +preDepends b = B.preDepends . B.relations . binaryDebDescription b + +-- | The Breaks: relations for each binary deb. +breaks :: BinPkgName -> Lens Atoms Relations +breaks b = B.breaks . B.relations . binaryDebDescription b + +-- | The Conflicts: relations for each binary deb. +conflicts :: BinPkgName -> Lens Atoms Relations +conflicts b = B.conflicts . B.relations . binaryDebDescription b + +-- | The Provides: relations for each binary deb. +provides :: BinPkgName -> Lens Atoms Relations +provides b = B.provides . B.relations . binaryDebDescription b + +-- | The Replaces: relations for each binary deb. +replaces :: BinPkgName -> Lens Atoms Relations +replaces b = B.replaces . B.relations . binaryDebDescription b + +builtUsing :: BinPkgName -> Lens Atoms Relations +builtUsing b = B.builtUsing . B.relations . binaryDebDescription b + +-- | Maintainer field. Overrides any value found in the cabal file, or +-- in the DEBIANMAINTAINER environment variable. +maintainer :: Lens Atoms (Maybe NameAddr) +maintainer = S.maintainer . control + +-- | The architectures supported by a binary package +binaryArchitectures :: BinPkgName -> Lens Atoms (Maybe PackageArchitectures) +binaryArchitectures b = B.architecture . binaryDebDescription b + +-- | The source package priority +sourcePriority :: Lens Atoms (Maybe PackagePriority) +sourcePriority = S.priority . control + +-- | Map of the binary package priorities (FIXME: redundant with BinaryDebDescription) +binaryPriority :: BinPkgName -> Lens Atoms (Maybe PackagePriority) +binaryPriority b = B.binaryPriority . binaryDebDescription b + +-- | The source package's section assignment +sourceSection :: Lens Atoms (Maybe Section) +sourceSection = S.section . control + +-- | Map of the binary deb section assignments (FIXME: redundant with BinaryDebDescription) +binarySection :: BinPkgName -> Lens Atoms (Maybe Section) +binarySection b = B.binarySection . binaryDebDescription b + +-- * Debian dependency info + +source :: Lens Atoms (Maybe SrcPkgName) +source = S.source . control + +changedBy :: Lens Atoms (Maybe NameAddr) +changedBy = S.changedBy . control + +uploaders :: Lens Atoms ([NameAddr]) +uploaders = S.uploaders . control + +dmUploadAllowed :: Lens Atoms (Bool) +dmUploadAllowed = S.dmUploadAllowed . control + +-- | The @Standards-Version@ field of the @debian/control@ file +standardsVersion :: Lens Atoms (Maybe StandardsVersion) +standardsVersion = S.standardsVersion . control + +homepage :: Lens Atoms (Maybe Text) +homepage = S.homepage . control + +vcsFields :: Lens Atoms (Set S.VersionControlSpec) +vcsFields = S.vcsFields . control + +xFields :: Lens Atoms (Set S.XField) +xFields = S.xFields . control + +buildDepends :: Lens Atoms Relations +buildDepends = S.buildDepends . control + +buildDependsIndep :: Lens Atoms Relations +buildDependsIndep = S.buildDependsIndep . control + +buildConflicts :: Lens Atoms Relations +buildConflicts = S.buildConflicts . control + +buildConflictsIndep :: Lens Atoms Relations +buildConflictsIndep = S.buildConflictsIndep . control + +binaryPackages :: Lens Atoms [B.BinaryDebDescription] +binaryPackages = S.binaryPackages . control diff --git a/src/Debian/Debianize/Types/Atoms.hs b/src/Debian/Debianize/Types/Atoms.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Types/Atoms.hs @@ -0,0 +1,615 @@ +-- | This module holds a long list of lenses that access the Atoms +-- record, the record that holds the input data from which the +-- debianization is to be constructed. +{-# LANGUAGE DeriveDataTypeable #-} +module Debian.Debianize.Types.Atoms +{- ( Atoms + , showAtoms + , newAtoms + , InstallFile(..) -- FIXME - lenses for this + , Server(..) -- FIXME - lenses for this + , Site(..) -- FIXME - lenses for this + , DebAction(..) + , DebType(..) + , PackageInfo(..) + ) -} where + +import Control.Category ((.)) +import Data.Lens.Lazy (Lens, lens, iso, getL) +import Data.Map as Map (Map) +import Data.Monoid (Monoid(..)) +import Data.Set as Set (Set) +import Data.Text (Text) +import Data.Version (Version) +import Debian.Changes (ChangeLog) +import Debian.Debianize.Types.Base (maybeLens, listElemLens) +import qualified Debian.Debianize.Types.BinaryDebDescription as B +import qualified Debian.Debianize.Types.SourceDebDescription as S +import Debian.Debianize.VersionSplits (VersionSplits) +import Debian.Orphans () +import Debian.Policy (PackageArchitectures, PackagePriority, Section, SourceFormat, StandardsVersion) +import Debian.Relation (BinPkgName, Relations, SrcPkgName) +import Debian.Version (DebianVersion) +import Distribution.License (License) +import Distribution.Package (PackageName) +import Distribution.PackageDescription as Cabal (FlagName, PackageDescription) +import Distribution.Simple.Compiler (CompilerId) +import Prelude hiding (init, init, log, log, unlines, (.)) +import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) + +-- | 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. +data Atoms + = Atoms + { noDocumentationLibrary_ :: Set Bool + -- ^ Do not produce a libghc-foo-doc package. FIXME: make this Bool or Maybe Bool + , noProfilingLibrary_ :: Set Bool + -- ^ Do not produce a libghc-foo-prof package. FIXME: make this Bool or Maybe Bool + , omitLTDeps_ :: Set Bool + -- ^ If present, don't generate the << dependency when we see a cabal + -- equals dependency. (The implementation of this was somehow lost.) + -- FIXME: make this Bool or Maybe Bool + , compilerVersion_ :: Maybe 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.) + , buildDir_ :: Set 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. + -- FIXME: make this FilePath or Maybe FilePath + , flags_ :: Flags + -- ^ Information regarding mode of operation - verbosity, dry-run, usage, etc + , debianNameMap_ :: Map PackageName VersionSplits + -- ^ Mapping from cabal package name and version to debian source + -- package name. This allows different ranges of cabal versions to + -- map to different debian source package names. + , control_ :: S.SourceDebDescription + -- ^ The parsed contents of the control file + , sourcePackageName_ :: Maybe SrcPkgName + -- ^ Name to give to the debian source package. If not supplied + -- the name is constructed from the cabal package name. Note that + -- DebianNameMap could encode this information if we already knew + -- the cabal package name, but we can't assume that. + , revision_ :: Maybe String + -- ^ Specify the revision string to use when converting the + -- cabal version to debian. + , debVersion_ :: Maybe 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. + , maintainerOld_ :: Maybe 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. + , cabalFlagAssignments_ :: Set (FlagName, Bool) + -- ^ Flags to pass to Cabal function finalizePackageDescription, + -- this can be used to control the flags in the cabal file. It + -- can be supplied to the cabal-debian binary using the --flags + -- option. + , sourceFormat_ :: Maybe SourceFormat + -- ^ Write debian/source/format + , watch_ :: Maybe Text + -- ^ Write debian/watch + , intermediateFiles_ :: Set (FilePath, Text) + -- ^ Put this text into a file with the given name in the debianization. + , rulesHead_ :: Maybe Text + -- ^ The header of the debian/rules file. The remainder is assembled + -- from DebRulesFragment values in the atom list. + , rulesFragments_ :: Set Text + -- ^ A Fragment of debian/rules + , warning_ :: Set Text + -- ^ A warning to be reported later + , utilsPackageNames_ :: Set BinPkgName + -- ^ Name of a package that will get left-over data files and executables. + -- If there are more than one, each package will get those files. + , changelog_ :: Maybe ChangeLog + -- ^ The changelog, first entry contains the source package name and version + , comments_ :: Maybe [[Text]] + -- ^ Each element is a comment to be added to the changelog, where the + -- element's text elements are the lines of the comment. + , missingDependencies_ :: Set BinPkgName + -- ^ Lets cabal-debian know that a package it might expect to exist + -- actually does not, so omit all uses in resulting debianization. + , extraLibMap_ :: Map String Relations + -- ^ Map a cabal Extra-Library name to a debian binary package name, + -- e.g. @ExtraLibMapping extraLibMap "cryptopp" "libcrypto-dev"@ adds a + -- build dependency *and* a regular dependency on @libcrypto-dev@ to + -- any package that has @cryptopp@ in its cabal Extra-Library list. + , execMap_ :: Map String Relations + -- ^ 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. + , epochMap_ :: Map PackageName Int + -- ^ Specify epoch numbers for the debian package generated from a + -- cabal package. Example: @EpochMapping (PackageName "HTTP") 1@. + , packageInfo_ :: Map PackageName PackageInfo + -- ^ Supply some info about a cabal package. + , compat_ :: Maybe Int + -- ^ The debhelper compatibility level, from debian/compat. + , copyright_ :: Maybe Text + -- ^ Copyright information + , license_ :: Maybe License + -- ^ License information Cabal License value + , licenseFile_ :: Maybe Text + -- ^ The contents of the file specified in the cabal license-file: field + , apacheSite_ :: Map BinPkgName (String, FilePath, Text) + -- ^ Have Apache configure a site using PACKAGE, DOMAIN, LOGDIR, and APACHECONFIGFILE + , logrotateStanza_ :: Map BinPkgName (Set Text) + -- ^ Add a stanza of a logrotate file to the binary package + , link_ :: Map BinPkgName (Set (FilePath, FilePath)) + -- ^ Create a symbolic link in the binary package + , postInst_ :: Map BinPkgName Text + -- ^ Script to run after install, should contain #DEBHELPER# line before exit 0 + , postRm_ :: Map BinPkgName Text + -- ^ Script to run after remove, should contain #DEBHELPER# line before exit 0 + , preInst_ :: Map BinPkgName Text + -- ^ Script to run before install, should contain #DEBHELPER# line before exit 0 + , preRm_ :: Map BinPkgName Text + -- ^ Script to run before remove, should contain #DEBHELPER# line before exit 0 + , sourceArchitecture_ :: Maybe PackageArchitectures + -- ^ Set the Architecture field of the source package + , binaryArchitectures_ :: Map BinPkgName PackageArchitectures + -- ^ Set the Architecture field of a binary package + , sourcePriority_ :: Maybe PackagePriority + -- ^ Set the Priority field of the source package + , binaryPriorities_ :: Map BinPkgName PackagePriority + -- ^ Set the Priority field of a binary package + , sourceSection_ :: Maybe Section + -- ^ Set the Section field of the source package + , binarySections_ :: Map BinPkgName Section + -- ^ Set the Section field of a binary package + , install_ :: Map BinPkgName (Set (FilePath, FilePath)) + -- ^ Install a build file into the binary package + , installTo_ :: Map BinPkgName (Set (FilePath, FilePath)) + -- ^ Install a build file into the binary package at an exact location + , installData_ :: Map BinPkgName (Set (FilePath, FilePath)) + -- ^ DHInstallTo somewhere relative to DataDir (see above) + , file_ :: Map BinPkgName (Set (FilePath, Text)) + -- ^ Create a file with the given text at the given path + , installCabalExec_ :: Map BinPkgName (Set (String, FilePath)) + -- ^ Install a cabal executable into the binary package + , installCabalExecTo_ :: Map BinPkgName (Set (String, FilePath)) + -- ^ Install a cabal executable into the binary package at an exact location + , installDir_ :: Map BinPkgName (Set FilePath) + -- ^ Create a directory in the binary package + , installInit_ :: Map BinPkgName Text + -- ^ Add an init.d file to the binary package + , executable_ :: Map BinPkgName InstallFile + -- ^ Create a binary package to hold a cabal executable + , serverInfo_ :: Map BinPkgName Server + -- ^ Like DHExecutable, but configure the executable as a server process + , website_ :: Map BinPkgName Site + -- ^ Like DHServer, but configure the server as a web server + , backups_ :: Map BinPkgName String + -- ^ Configure the executable to do incremental backups + , extraDevDeps_ :: Relations + -- ^ 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. + , packageDescription_ :: Maybe PackageDescription + -- ^ The result of reading a cabal configuration file. + , compiler_ :: Maybe CompilerId + -- ^ The compiler value from cabal + } deriving (Eq, Show) + +newAtoms :: Atoms +newAtoms + = Atoms + { noDocumentationLibrary_ = mempty + , noProfilingLibrary_ = mempty + , omitLTDeps_ = mempty + , compilerVersion_ = Nothing + , buildDir_ = mempty + , flags_ = defaultFlags + , debianNameMap_ = mempty + , control_ = S.newSourceDebDescription + , sourcePackageName_ = Nothing + , revision_ = Nothing + , debVersion_ = Nothing + , maintainerOld_ = Nothing + , cabalFlagAssignments_ = mempty + , sourceFormat_ = Nothing + , watch_ = Nothing + , intermediateFiles_ = mempty + , rulesHead_ = Nothing + , rulesFragments_ = mempty + , warning_ = mempty + , utilsPackageNames_ = mempty + , changelog_ = Nothing + , comments_ = Nothing + , missingDependencies_ = mempty + , extraLibMap_ = mempty + , execMap_ = mempty + , epochMap_ = mempty + , packageInfo_ = mempty + , compat_ = Nothing + , copyright_ = Nothing + , license_ = Nothing + , licenseFile_ = mempty + , apacheSite_ = mempty + , logrotateStanza_ = mempty + , link_ = mempty + , postInst_ = mempty + , postRm_ = mempty + , preInst_ = mempty + , preRm_ = mempty + , sourceArchitecture_ = Nothing + , binaryArchitectures_ = mempty + , sourcePriority_ = Nothing + , binaryPriorities_ = mempty + , sourceSection_ = Nothing + , binarySections_ = mempty + , install_ = mempty + , installTo_ = mempty + , installData_ = mempty + , file_ = mempty + , installCabalExec_ = mempty + , installCabalExecTo_ = mempty + , installDir_ = mempty + , installInit_ = mempty + , executable_ = mempty + , serverInfo_ = mempty + , website_ = mempty + , backups_ = mempty + , extraDevDeps_ = mempty + , packageDescription_ = Nothing + , compiler_ = Nothing + } + +-- | 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) + +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) + +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) + +defaultFlags :: Flags +defaultFlags = + Flags { + verbosity_ = 1 + , debAction_ = Debianize + , dryRun_ = False + , validate_ = False + } + +showAtoms :: Atoms -> IO () +showAtoms x = putStrLn ("\nTop: " ++ show x ++ "\n") + +-- | Set how much progress messages get generated. +verbosity :: Lens Atoms Int +verbosity = lens verbosity_ (\ b a -> a {verbosity_ = b}) . flags + +-- | Don't write anything, just output a description of what would have happened +dryRun :: Lens Atoms Bool +dryRun = lens dryRun_ (\ b a -> a {dryRun_ = b}) . flags + +-- | Make sure the version number and package names of the supplied +-- and generated debianizations match. +validate :: Lens Atoms Bool +validate = lens validate_ (\ b a -> a {validate_ = b}) . flags + +-- | 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 debAction_ (\ b a -> a {debAction_ = b}) . flags + +-- | Obsolete record containing verbosity, dryRun, validate, and debAction. +flags :: Lens Atoms Flags +flags = lens flags_ (\ b a -> a {flags_ = b}) + +-- | Unused +warning :: Lens Atoms (Set Text) +warning = lens warning_ (\ a b -> b {warning_ = a}) + +-- | Set the compiler version, this is used when loading the cabal file to +compilerVersion :: Lens Atoms (Maybe Version) +compilerVersion = lens compilerVersion_ (\ b a -> a {compilerVersion_ = b}) + +-- | 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 (Set FilePath) +buildDir = lens buildDir_ (\ b a -> a {buildDir_ = b}) + +-- | Map from cabal Extra-Lib names to debian binary package names. +extraLibMap :: Lens Atoms (Map String Relations) +extraLibMap = lens extraLibMap_ (\ a b -> b {extraLibMap_ = a}) + +-- | Map from cabal Build-Tool names to debian binary package names. +execMap :: Lens Atoms (Map String Relations) +execMap = lens execMap_ (\ a b -> b {execMap_ = a}) + +-- | Cabal flag assignments to use when loading the cabal file. +cabalFlagAssignments :: Lens Atoms (Set (FlagName, Bool)) +cabalFlagAssignments = lens cabalFlagAssignments_ (\ a b -> b {cabalFlagAssignments_ = a}) + +-- | The result of loading a .cabal file +packageDescription :: Lens Atoms (Maybe PackageDescription) +packageDescription = lens packageDescription_ (\ a b -> b {packageDescription_ = a}) + +-- | Another result of loading a .cabal file +compiler :: Lens Atoms (Maybe CompilerId) +compiler = lens compiler_ (\ a b -> b {compiler_ = a}) + +-- | 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 package can. +debianNameMap :: Lens Atoms (Map PackageName VersionSplits) +debianNameMap = lens debianNameMap_ (\ a b -> b {debianNameMap_ = a}) + +-- | Map of Debian epoch numbers assigned to cabal packages. +epochMap :: Lens Atoms (Map PackageName Int) +epochMap = lens epochMap_ (\ a b -> b {epochMap_ = a}) + +-- | Create a package to hold a cabal executable +executable :: Lens Atoms (Map BinPkgName InstallFile) +executable = lens executable_ (\ a b -> b {executable_ = a}) + +-- | Create a package for a server +serverInfo :: Lens Atoms (Map BinPkgName Server) +serverInfo = lens serverInfo_ (\ a b -> b {serverInfo_ = a}) + +-- | Create a package for a website +website :: Lens Atoms (Map BinPkgName Site) +website = lens website_ (\ a b -> b {website_ = a}) + +-- | Create a package for a timed backup script +backups :: Lens Atoms (Map BinPkgName String) +backups = lens backups_ (\ a b -> b {backups_ = a}) + +-- | 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 apacheSite_ (\ a b -> b {apacheSite_ = a}) + +-- * 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 missingDependencies_ (\ a b -> b {missingDependencies_ = a}) + +-- | Override the package name used to hold left over data files and executables. +-- Usually only one package is specified, but if more then one are they will each +-- receive the same list of files. +utilsPackageNames :: Lens Atoms (Set BinPkgName) +utilsPackageNames = lens utilsPackageNames_ (\ a b -> b {utilsPackageNames_ = a}) + +-- | Override the debian source package name constructed from the cabal name +sourcePackageName :: Lens Atoms (Maybe SrcPkgName) +sourcePackageName = lens sourcePackageName_ (\ a b -> b {sourcePackageName_ = a}) + +-- | Revision string used in constructing the debian verison number from the cabal version +revision :: Lens Atoms (Maybe String) +revision = lens revision_ (\ a b -> b {revision_ = a}) + +-- | Exact debian version number, overrides the version generated from the cabal version +debVersion :: Lens Atoms (Maybe DebianVersion) +debVersion = lens debVersion_ (\ b a -> a {debVersion_ = b}) + +-- | No longer sure what the purpose of this lens is. +packageInfo :: Lens Atoms (Map PackageName PackageInfo) +packageInfo = lens packageInfo_ (\ a b -> b {packageInfo_ = a}) + +-- | Set this to filter any less-than dependencies out of the generated debian +-- dependencies. (Not sure if this is implemented.) +omitLTDeps :: Lens Atoms (Set Bool) +omitLTDeps = lens omitLTDeps_ (\ b a -> a {omitLTDeps_ = b}) + +-- | Set this to omit the prof library deb. +noProfilingLibrary :: Lens Atoms (Set Bool) +noProfilingLibrary = lens noProfilingLibrary_ (\ b a -> a {noProfilingLibrary_ = b}) + +-- | Set this to omit the doc library deb. +noDocumentationLibrary :: Lens Atoms (Set Bool) +noDocumentationLibrary = lens noDocumentationLibrary_ (\ b a -> a {noDocumentationLibrary_ = b}) + +-- | The copyright information from the cabal file +copyright :: Lens Atoms (Maybe Text) +copyright = lens copyright_ (\ a b -> b {copyright_ = a}) + +-- | The license information from the cabal file +license :: Lens Atoms (Maybe License) +license = lens license_ (\ a b -> b {license_ = a}) + +-- | The value in the cabal file's license-file field +licenseFile :: Lens Atoms (Maybe Text) +licenseFile = lens licenseFile_ (\ a b -> b {licenseFile_ = a}) + +-- | The architectures supported by this source package - @Any@, +-- @All@, or some list of specific architectures. +sourceArchitectures :: Lens Atoms (Maybe PackageArchitectures) +sourceArchitectures = lens sourceArchitecture_ (\ a b -> b {sourceArchitecture_ = a}) + +-- | 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 Relations +extraDevDeps = lens extraDevDeps_ (\ a b -> b {extraDevDeps_ = a}) + +-- | The beginning of the rules file +rulesHead :: Lens Atoms (Maybe Text) +rulesHead = lens rulesHead_ (\ a b -> b {rulesHead_ = a}) + +-- | Additional fragments of the rules file +rulesFragments :: Lens Atoms (Set Text) +rulesFragments = lens rulesFragments_ (\ a b -> b {rulesFragments_ = a}) + +-- | Map of @debian/postinst@ scripts +postInst :: Lens Atoms (Map BinPkgName Text) +postInst = lens postInst_ (\ a b -> b {postInst_ = a}) + +-- | Map of @debian/postrm@ scripts +postRm :: Lens Atoms (Map BinPkgName Text) +postRm = lens postRm_ (\ a b -> b {postRm_ = a}) + +-- | Map of @debian/preinst@ scripts +preInst :: Lens Atoms (Map BinPkgName Text) +preInst = lens preInst_ (\ a b -> b {preInst_ = a}) + +-- | Map of @debian/prerm@ scripts +preRm :: Lens Atoms (Map BinPkgName Text) +preRm = lens preRm_ (\ a b -> b {preRm_ = a}) + +-- | The @debian/compat@ file, contains the minimum compatible version +-- of the @debhelper@ package. If not given the version number of the +-- installed debhelper package is used. +compat :: Lens Atoms (Maybe Int) +compat = lens compat_ (\ a b -> b {compat_ = a}) + +-- | The @debian\/source\/format@ file. +sourceFormat :: Lens Atoms (Maybe SourceFormat) +sourceFormat = lens sourceFormat_ (\ a b -> b {sourceFormat_ = a}) + +-- | the @debian\/watch@ file +watch :: Lens Atoms (Maybe Text) +watch = lens watch_ (\ a b -> b {watch_ = a}) + +-- | the @debian\/changelog@ file +changelog :: Lens Atoms (Maybe ChangeLog) +changelog = lens changelog_ (\ a b -> b {changelog_ = a}) + +-- | Comment entries for the latest changelog entry (DebLogComments [[Text]]) +comments :: Lens Atoms (Maybe [[Text]]) +comments = lens comments_ (\ a b -> b {comments_ = a}) + +-- | The @debian\/control@ file. Many of the following lenses access parts of the @SourceDebDescription@. +control :: Lens Atoms S.SourceDebDescription +control = lens control_ (\ a b -> b {control_ = a}) + +-- | Add a stanza to the binary package's logrotate script. +logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text)) +logrotateStanza = lens logrotateStanza_ (\ a b -> b {logrotateStanza_ = a}) + +-- | Add entries to a binary deb's debian/foo.links file. +link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +link = lens link_ (\ a b -> b {link_ = a}) + +-- | Install files into directories by adding entries to the binary +-- deb's debian/foo.install file. +install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +install = lens install_ (\ a b -> b {install_ = a}) + +-- | Rename and install files. This is done by adding rules to debian/rules. +installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +installTo = lens installTo_ (\ a b -> b {installTo_ = a}) + +-- | Install files into the a binary deb's data directory, +-- /usr/share/packagename-version. This expands to either an install +-- or an installTo. +installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) +installData = lens installData_ (\ a b -> b {installData_ = a}) + +-- | Create a file in the binary deb with the given text. This is done by +-- writing the file into the cabalInstall directory and adding an entry +-- to the binary deb's .install file. +file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text))) +file = lens file_ (\ a b -> b {file_ = a}) + +-- | Install a cabal executable into a binary deb. +-- FIXME: change signature to BinPkgName -> Lens Atoms (Set (String, FilePath)) +installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) +installCabalExec = lens installCabalExec_ (\ a b -> b {installCabalExec_ = a}) + +-- | Rename and install a cabal executable +-- FIXME: change signature to BinPkgName -> Lens Atoms (Set (String, FilePath)) +installCabalExecTo :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) +installCabalExecTo = lens installCabalExecTo_ (\ a b -> b {installCabalExecTo_ = a}) + +-- | Create directories in the package +-- FIXME: change signature to BinPkgName -> Lens Atoms (Set FilePath) +installDir :: Lens Atoms (Map BinPkgName (Set FilePath)) +installDir = lens installDir_ (\ a b -> b {installDir_ = a}) + +-- | Create an /etc/init.d file in the package +-- FIXME: change signature to BinPkgName -> Lens Atoms Text +installInit :: Lens Atoms (Map BinPkgName Text) +installInit = lens installInit_ (\ a b -> b {installInit_ = a}) + +-- | Create a file in the debianization. This is used to implement the file lens above. +-- FIXME: change signature to BinPkgName -> Lens Atoms (Set (FilePath, Text)) +intermediateFiles :: Lens Atoms (Set (FilePath, Text)) +intermediateFiles = lens intermediateFiles_ (\ a b -> b {intermediateFiles_ = a}) diff --git a/src/Debian/Debianize/Types/Base.hs b/src/Debian/Debianize/Types/Base.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Types/Base.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections, TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +module Debian.Debianize.Types.Base + ( Top(..) + , listElemLens + , maybeLens + ) where + +import Control.Category ((.)) +import Data.Generics (Typeable) +import Data.Lens.Lazy (getL, lens, Lens, setL) +import Data.Maybe (fromMaybe) +import Prelude hiding ((.)) + +-- | This is a special filepath that represents the top of a directory +-- tree. For a cabal package this directory would contain the .cabal +-- file, for a debian package it would contain the debian directory. +newtype Top = Top {unTop :: FilePath} deriving (Eq, Ord, Show, Typeable) + +listElemLens :: (a -> Bool) -> Lens [a] (Maybe a) +listElemLens p = + lens lensGet lensPut + where + lensGet xs = + case span (not . p) xs of + (_, x : _) -> Just x + _ -> Nothing + lensPut Nothing xs = + case span (not . p) xs of + (pre, _ : post) -> pre ++ post + _ -> xs + lensPut (Just x) xs = + case span (not . p) xs of + (pre, _ : post) -> pre ++ (x : post) + _ -> xs ++ [x] + +maybeLens :: a -> Lens a b -> Lens (Maybe a) b +maybeLens def l = + lens (getL l . fromMaybe def) + (\ a b -> case (a, b) of + (_, Nothing) -> Just (setL l a def) + (_, Just b') -> Just (setL l a b')) diff --git a/src/Debian/Debianize/Types/BinaryDebDescription.hs b/src/Debian/Debianize/Types/BinaryDebDescription.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Types/BinaryDebDescription.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +{-# OPTIONS -Wall #-} +module Debian.Debianize.Types.BinaryDebDescription + ( BinaryDebDescription + , newBinaryDebDescription + , package + , description + , packageType + , architecture + , binarySection + , binaryPriority + , essential + , relations + + , PackageType(..) + + , PackageRelations + , newPackageRelations + , depends + , recommends + , suggests + , preDepends + , breaks + , conflicts + , provides + , replaces + , builtUsing + ) where + +import Data.Generics (Data, Typeable) +import Data.Lens.Template (makeLenses) +import Data.Monoid (Monoid(..)) +import Data.Text (Text) +import Debian.Policy (PackageArchitectures, PackagePriority, Section) +import Debian.Relation (BinPkgName, Relations) +import Prelude hiding ((.)) + +-- | 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 + -- ^ + , _packageType :: Maybe PackageType + , _architecture :: Maybe PackageArchitectures + -- ^ + , _binarySection :: Maybe Section + , _binaryPriority :: Maybe PackagePriority + , _essential :: Maybe Bool + -- ^ + , _description :: Maybe Text + -- ^ + , _relations :: PackageRelations + -- ^ + } deriving (Eq, Ord, Read, Show, Data, Typeable) + +-- ^ 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, Ord, Show, Read, Data, Typeable) + +-- ^ 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) + +newBinaryDebDescription :: BinPkgName -> BinaryDebDescription +newBinaryDebDescription name = + BinaryDebDescription + { _package = name + , _packageType = Nothing + , _architecture = Nothing + , _binarySection = Nothing + , _binaryPriority = Nothing + , _essential = Nothing + , _description = mempty + , _relations = newPackageRelations } + +newPackageRelations :: PackageRelations +newPackageRelations = + PackageRelations + { _depends = [] + , _recommends = [] + , _suggests = [] + , _preDepends = [] + , _breaks = [] + , _conflicts = [] + , _provides = [] + , _replaces = [] + , _builtUsing = [] } + +$(makeLenses [''BinaryDebDescription, ''PackageRelations]) diff --git a/src/Debian/Debianize/Types/SourceDebDescription.hs b/src/Debian/Debianize/Types/SourceDebDescription.hs new file mode 100644 --- /dev/null +++ b/src/Debian/Debianize/Types/SourceDebDescription.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +module Debian.Debianize.Types.SourceDebDescription + ( SourceDebDescription + , newSourceDebDescription + , newSourceDebDescription' + , source + , maintainer + , changedBy + , uploaders + , dmUploadAllowed + , priority + , section + , buildDepends + , buildConflicts + , buildDependsIndep + , buildConflictsIndep + , standardsVersion + , homepage + , vcsFields + , xFields + , binaryPackages + , VersionControlSpec(..) + , XField(..) + , XFieldDest(..) + ) where + +import Data.Generics (Data, Typeable) +import Data.Lens.Template (makeLenses) +import Data.Set as Set (empty, Set) +import Data.Text (Text) +import Debian.Debianize.Types.BinaryDebDescription (BinaryDebDescription) +import Debian.Orphans () +import Debian.Policy (PackagePriority, Section, StandardsVersion) +import Debian.Relation (Relations, SrcPkgName) +import Prelude hiding (init, init, log, log, unlines) +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] + -- ^ The binary debs. This should be a map, but we may need to preserve the order + } 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) + +$(makeLenses [''SourceDebDescription]) diff --git a/src/Debian/Debianize/Types/VersionSplits.hs b/src/Debian/Debianize/Types/VersionSplits.hs deleted file mode 100644 --- a/src/Debian/Debianize/Types/VersionSplits.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} -module Debian.Debianize.Types.VersionSplits - ( VersionSplits - , packageRangesFromVersionSplits - , makePackage - , insertSplit - , doSplits - , knownVersionSplits - ) where - -import Data.Version (Version(Version), showVersion) -import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples) -import Data.Map as Map (Map, fromList) -import Debian.Orphans () -import qualified Debian.Relation as D -import Debian.Version (parseDebianVersion) -import Distribution.Package (PackageName(PackageName)) -import Distribution.Version (VersionRange, anyVersion, intersectVersionRanges, earlierVersion, orLaterVersion) -import Prelude hiding (init, unlines, log) - --- | Describes a mapping from cabal package name and version to debian --- package names. For example, versions of the cabal QuickCheck --- package less than 2 are mapped to "quickcheck1", while version 2 or --- greater is mapped to "quickcheck2". -data VersionSplits - = VersionSplits { - oldestPackage :: String - -- ^ The name given to versions older than the oldest split. - , splits :: [(Version, String)] - -- ^ Each pair is The version where the split occurs, and the - -- name to use for versions greater than or equal to that - -- version. This list assumed to be in (must be kept in) - -- ascending version number order. - } deriving (Eq, Ord, Show) - -makePackage :: String -> VersionSplits -makePackage name = VersionSplits {oldestPackage = name, splits = []} - --- | Split the version range and give the older packages a new name. -insertSplit :: Version -> String -> VersionSplits -> VersionSplits -insertSplit ver@(Version _ _) ltname sp@(VersionSplits {}) = - -- (\ x -> trace ("insertSplit " ++ show (ltname, ver, sp) ++ " -> " ++ show x) x) $ - case splits sp of - -- This is the oldest split, change oldestPackage and insert a new head pair - (ver', _) : _ | ver' > ver -> sp {oldestPackage = ltname, splits = (ver, oldestPackage sp) : splits sp} - [] -> sp {oldestPackage = ltname, splits = [(ver, oldestPackage sp)]} - -- Not the oldest split, insert it in its proper place. - _ -> sp {splits = reverse (insert (reverse (splits sp)))} - where - -- Insert our new split into the reversed list - insert ((ver', name') : more) = - if ver' < ver - then (ver, name') : (ver', ltname) : more - else (ver', name') : insert more - -- ver' is older, change oldestPackage - insert [] = [(ver, oldestPackage sp)] - -- ltname = base ++ "-" ++ (show (last ns - 1)) - -instance Interspersed VersionSplits String Version where - leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance" - leftmost (VersionSplits {oldestPackage = p}) = p - pairs (VersionSplits {splits = xs}) = xs - -packageRangesFromVersionSplits :: VersionSplits -> [(String, VersionRange)] -packageRangesFromVersionSplits s = - foldInverted (\ older dname newer more -> - (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more) - [] - s - -doSplits :: VersionSplits -> Maybe D.VersionReq -> String -doSplits s version = - foldTriples' (\ ltName v geName _ -> - 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) - (oldestPackage s) - s - where - foldTriples' :: (String -> Version -> String -> String -> String) -> String -> VersionSplits -> String - foldTriples' = foldTriples - --- | 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 :: Map PackageName VersionSplits -knownVersionSplits = - Map.fromList - [ (PackageName "parsec", VersionSplits {oldestPackage = "parsec2", splits = [(Version [3] [], "parsec3")]}) - , (PackageName "QuickCheck", VersionSplits {oldestPackage = "quickcheck1", splits = [(Version [2] [], "quickcheck2")]}) - -- This just gives a special case cabal to debian name mapping. - , (PackageName "gtk2hs-buildtools", VersionSplits {oldestPackage = "gtk2hs-buildtools", splits = []}) ] diff --git a/src/Debian/Debianize/Utility.hs b/src/Debian/Debianize/Utility.hs deleted file mode 100644 --- a/src/Debian/Debianize/Utility.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | 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' - , readFileMaybe - , showDeps - , showDeps' - , withCurrentDirectory - , getDirectoryContents' - , setMapMaybe - , zipMaps - , foldEmpty - , maybeL - , indent - , maybeRead - , read' - ) where - -import Control.Applicative ((<$>)) -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, listToMaybe, fromMaybe) -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, catchIOError) -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 - -readFileMaybe :: FilePath -> IO (Maybe Text) -readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\ _ -> return Nothing) - --- 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)) - -maybeRead :: Read a => String -> Maybe a -maybeRead = fmap fst . listToMaybe . reads - -read' :: Read a => (String -> a) -> String -> a -read' f s = fromMaybe (f s) (maybeRead s) - --- read' :: Read a => String -> a --- read' s = trace ("read " ++ show s) (read s) diff --git a/src/Debian/Debianize/VersionSplits.hs b/src/Debian/Debianize/VersionSplits.hs --- a/src/Debian/Debianize/VersionSplits.hs +++ b/src/Debian/Debianize/VersionSplits.hs @@ -1,31 +1,100 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} module Debian.Debianize.VersionSplits - ( mapCabal - , splitCabal + ( VersionSplits + , packageRangesFromVersionSplits + , makePackage + , insertSplit + , doSplits + , knownVersionSplits ) where -import Data.Lens.Lazy (modL) -import Data.Map as Map (alter) -import Data.Version (Version) -import Debian.Debianize.Atoms (Atoms, debianNameMap) -import Debian.Debianize.Types.VersionSplits (VersionSplits, makePackage, insertSplit) -import Distribution.Package (PackageName) +import Data.Version (Version(Version), showVersion) +import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples) +import Data.Map as Map (Map, fromList) +import Debian.Orphans () +import qualified Debian.Relation as D +import Debian.Version (parseDebianVersion) +import Distribution.Package (PackageName(PackageName)) +import Distribution.Version (VersionRange, anyVersion, intersectVersionRanges, earlierVersion, orLaterVersion) +import Prelude hiding (init, unlines, log) --- | Add a VersionSplits value to 'atoms' that maps the given cabal --- name 'pname' to the given debian name 'dname'. -mapCabal :: PackageName -> String -> Atoms -> Atoms -mapCabal pname dname atoms = - modL debianNameMap (Map.alter f pname) atoms +-- | Describes a mapping from cabal package name and version to debian +-- package names. For example, versions of the cabal QuickCheck +-- package less than 2 are mapped to "quickcheck1", while version 2 or +-- greater is mapped to "quickcheck2". +data VersionSplits + = VersionSplits { + oldestPackage :: String + -- ^ The name given to versions older than the oldest split. + , splits :: [(Version, String)] + -- ^ Each pair is The version where the split occurs, and the + -- name to use for versions greater than or equal to that + -- version. This list assumed to be in (must be kept in) + -- ascending version number order. + } deriving (Eq, Ord, Show) + +makePackage :: String -> VersionSplits +makePackage name = VersionSplits {oldestPackage = name, splits = []} + +-- | Split the version range and give the older packages a new name. +insertSplit :: Version -> String -> VersionSplits -> VersionSplits +insertSplit ver@(Version _ _) ltname sp@(VersionSplits {}) = + -- (\ x -> trace ("insertSplit " ++ show (ltname, ver, sp) ++ " -> " ++ show x) x) $ + case splits sp of + -- This is the oldest split, change oldestPackage and insert a new head pair + (ver', _) : _ | ver' > ver -> sp {oldestPackage = ltname, splits = (ver, oldestPackage sp) : splits sp} + [] -> sp {oldestPackage = ltname, splits = [(ver, oldestPackage sp)]} + -- Not the oldest split, insert it in its proper place. + _ -> sp {splits = reverse (insert (reverse (splits sp)))} where - f :: Maybe VersionSplits -> Maybe VersionSplits - f Nothing = Just (makePackage dname) - f (Just sp) = error $ "mapCabal - already mapped: " ++ show sp + -- Insert our new split into the reversed list + insert ((ver', name') : more) = + if ver' < ver + then (ver, name') : (ver', ltname) : more + else (ver', name') : insert more + -- ver' is older, change oldestPackage + insert [] = [(ver, oldestPackage sp)] + -- ltname = base ++ "-" ++ (show (last ns - 1)) --- | Map the versions of 'pname' less than 'ver' to the given debian --- name 'ltname'. -splitCabal :: PackageName -> String -> Version -> Atoms -> Atoms -splitCabal pname ltname ver atoms = - modL debianNameMap (Map.alter f pname) atoms +instance Interspersed VersionSplits String Version where + leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance" + leftmost (VersionSplits {oldestPackage = p}) = p + pairs (VersionSplits {splits = xs}) = xs + +packageRangesFromVersionSplits :: VersionSplits -> [(String, VersionRange)] +packageRangesFromVersionSplits s = + foldInverted (\ older dname newer more -> + (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more) + [] + s + +doSplits :: VersionSplits -> Maybe D.VersionReq -> String +doSplits s version = + foldTriples' (\ ltName v geName _ -> + 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) + (oldestPackage s) + s where - f :: Maybe VersionSplits -> Maybe VersionSplits - f Nothing = error $ "splitCabal - not mapped: " ++ show pname - f (Just sp) = Just (insertSplit ver ltname sp) + foldTriples' :: (String -> Version -> String -> String -> String) -> String -> VersionSplits -> String + foldTriples' = foldTriples + +-- | 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 :: Map PackageName VersionSplits +knownVersionSplits = + Map.fromList + [ (PackageName "parsec", VersionSplits {oldestPackage = "parsec2", splits = [(Version [3] [], "parsec3")]}) + , (PackageName "QuickCheck", VersionSplits {oldestPackage = "quickcheck1", splits = [(Version [2] [], "quickcheck2")]}) + -- This just gives a special case cabal to debian name mapping. + , (PackageName "gtk2hs-buildtools", VersionSplits {oldestPackage = "gtk2hs-buildtools", splits = []}) ] diff --git a/src/Debian/Policy.hs b/src/Debian/Policy.hs --- a/src/Debian/Policy.hs +++ b/src/Debian/Policy.hs @@ -44,7 +44,7 @@ import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack, strip) -import Debian.Debianize.Utility (read') +import Debian.Debianize.Prelude (read') import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion, parseDebianVersion, version) import System.Environment (getEnvironment) @@ -93,7 +93,11 @@ parseDebianVersion' "" = Nothing parseDebianVersion' s = Just (parseDebianVersion s) --- | Assumes debhelper is installed +-- | The version number of the installed debhelper package is the +-- highest acceptable value for compat in a debian/control file. If +-- the package doesn't explicitly set an (acceptable) compat value we +-- can use the value returned by this function, assuming debhelper is +-- installed. getDebhelperCompatLevel :: IO (Maybe Int) getDebhelperCompatLevel = debianPackageVersion "debhelper" >>= return . fmap (read . takeWhile (/= '.') . version) @@ -241,6 +245,8 @@ NameAddr { nameAddr_name = Just "Debian Haskell Group" , nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"} +-- | Turn the uploaders field of a cabal package into a list of +-- RFC2822 NameAddr values. parseUploaders :: String -> Either String [NameAddr] parseUploaders x = either (Left . show) fixNameAddrs (parse address "" ("Names: " ++ map fixWhite x ++ ";")) @@ -258,6 +264,7 @@ Nothing -> Nothing _ -> Just y +-- | Parse a string containing a single NameAddr value. parseMaintainer :: String -> Either String NameAddr parseMaintainer x = case parseUploaders x of