cabal-debian 3.9 → 4.0.3
raw patch · 32 files changed
+4231/−3855 lines, 32 filesdep +data-lens-templatedep +set-extradep −cabal-debiandep ~debiandep ~parsec
Dependencies added: data-lens-template, set-extra
Dependencies removed: cabal-debian
Dependency ranges changed: debian, parsec
Files
- cabal-debian.cabal +160/−42
- changelog +52/−0
- debian/Debianize.hs +63/−35
- src/CabalDebian.hs +42/−18
- src/Debian/Debianize.hs +133/−34
- src/Debian/Debianize/Atoms.hs +0/−1261
- src/Debian/Debianize/Bundled.hs +5/−5
- src/Debian/Debianize/Changelog.hs +31/−0
- src/Debian/Debianize/ControlFile.hs +0/−206
- src/Debian/Debianize/DebianName.hs +104/−0
- src/Debian/Debianize/Debianize.hs +0/−319
- src/Debian/Debianize/Dependencies.hs +0/−407
- src/Debian/Debianize/Details.hs +34/−31
- src/Debian/Debianize/Files.hs +157/−127
- src/Debian/Debianize/Finalize.hs +646/−254
- src/Debian/Debianize/Goodies.hs +146/−133
- src/Debian/Debianize/Input.hs +216/−147
- src/Debian/Debianize/Monad.hs +50/−0
- src/Debian/Debianize/Options.hs +92/−59
- src/Debian/Debianize/Output.hs +138/−0
- src/Debian/Debianize/Prelude.hs +327/−0
- src/Debian/Debianize/SubstVars.hs +145/−59
- src/Debian/Debianize/Tests.hs +448/−299
- src/Debian/Debianize/Types.hs +246/−46
- src/Debian/Debianize/Types/Atoms.hs +615/−0
- src/Debian/Debianize/Types/Base.hs +42/−0
- src/Debian/Debianize/Types/BinaryDebDescription.hs +112/−0
- src/Debian/Debianize/Types/SourceDebDescription.hs +125/−0
- src/Debian/Debianize/Types/VersionSplits.hs +0/−100
- src/Debian/Debianize/Utility.hs +0/−247
- src/Debian/Debianize/VersionSplits.hs +93/−24
- src/Debian/Policy.hs +9/−2
cabal-debian.cabal view
@@ -1,5 +1,5 @@ Name: cabal-debian-Version: 3.9+Version: 4.0.3 License: BSD3 License-File: debian/copyright Author: David Fox <dsf@seereason.com>@@ -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
changelog view
@@ -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 <dsf@seereason.com> 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 <dsf@seereason.com> 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 <dsf@seereason.com> Tue, 10 Dec 2013 05:10:11 -0800++haskell-cabal-debian (4.0.0) unstable; urgency=low++ * Massive lens overhaul++ -- David Fox <dsf@seereason.com> 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 <dsf@seereason.com> 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 <dsf@seereason.com> 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 <dsf@seereason.com> Tue, 19 Nov 2013 11:31:16 -0800++haskell-cabal-debian (3.10) unstable; urgency=low++ * Add a monadic interface++ -- David Fox <dsf@seereason.com> Sat, 16 Nov 2013 10:42:02 -0800+ haskell-cabal-debian (3.9) unstable; urgency=low * Clean up documentation
debian/Debianize.hs view
@@ -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 <dsf@seereason.com>"- , " Upstream-Maintainer: David Fox <dsf@seereason.com>" ])))+ 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 <dsf@seereason.com>"+ , " Upstream-Maintainer: David Fox <dsf@seereason.com>" ]))+ 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)+-}
src/CabalDebian.hs view
@@ -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 <maintainer@email>'."+ , ""+ , "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)
src/Debian/Debianize.hs view
@@ -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
− src/Debian/Debianize/Atoms.hs
@@ -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
src/Debian/Debianize/Bundled.hs view
@@ -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
+ src/Debian/Debianize/Changelog.hs view
@@ -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 }
− src/Debian/Debianize/ControlFile.hs
@@ -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- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Source>- , maintainer :: Maybe NameAddr- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Maintainer>- , changedBy :: Maybe NameAddr- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Changed-By>- , uploaders :: [NameAddr]- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Uploaders>- , dmUploadAllowed :: Bool- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-DM-Upload-Allowed>- , priority :: Maybe PackagePriority- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Priority>- , section :: Maybe Section- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Section>- , standardsVersion :: Maybe StandardsVersion- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Standards-Version>- , homepage :: Maybe Text- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Homepage>- , vcsFields :: Set VersionControlSpec- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-VCS-fields>- , xFields :: Set XField- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.7>- , 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- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package>- , architecture :: PackageArchitectures- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Architecture>- , binarySection :: Maybe Section- , binaryPriority :: Maybe PackagePriority- , essential :: Bool- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Essential>- , description :: Text- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Description>- , relations :: PackageRelations- -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.6.10>- } 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
+ src/Debian/Debianize/DebianName.hs view
@@ -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)
− src/Debian/Debianize/Debianize.hs
@@ -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 <maintainer@email>'."- , ""- , "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
− src/Debian/Debianize/Dependencies.hs
@@ -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 ++ "=<debname> or modL execMap (Map.insert (PackageName " ++ show pkg ++ ") (BinPkgName \"<debname>\")"- 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))
src/Debian/Debianize/Details.hs view
@@ -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] [])
src/Debian/Debianize/Files.hs view
@@ -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)]
src/Debian/Debianize/Finalize.hs view
@@ -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 ++ "=<debname> or execMap " ++ show pkg +++ " [[Rel (BinPkgName \"<debname>\") 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)
src/Debian/Debianize/Goodies.hs view
@@ -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 $ [ "<VirtualHost *:80>"- , " 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' <> "/" , "</VirtualHost>" ]- 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"]
src/Debian/Debianize/Input.hs view
@@ -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
+ src/Debian/Debianize/Monad.hs view
@@ -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
src/Debian/Debianize/Options.hs view
@@ -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-<cabalname>, 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 <email addr>")+ Option "" ["maintainer"] (ReqArg (\ maint -> either (error ("Invalid maintainer string: " ++ show maint)) ((maintainer ~=) . Just) (parseMaintainer maint)) "Maintainer Name <email addr>") (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 =
+ src/Debian/Debianize/Output.hs view
@@ -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
+ src/Debian/Debianize/Prelude.hs view
@@ -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
src/Debian/Debianize/SubstVars.hs view
@@ -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)
src/Debian/Debianize/Tests.hs view
@@ -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 <dsf@seereason.com>" , 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 <dsf@seereason.com>", 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 <dsf@seereason.com> 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 <jgoerzen@complete.org> 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 <jgoerzen@complete.org> 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 <nomeata@debian.org>" , 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 <dsf@seereason.com>")+ 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 <dsf@seereason.com> 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
src/Debian/Debianize/Types.hs view
@@ -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/<execName>/- , destDir :: Maybe FilePath -- ^ where to put it, default is usr/bin/<execName>- , 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
+ src/Debian/Debianize/Types/Atoms.hs view
@@ -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/<execName>/+ , destDir :: Maybe FilePath -- ^ where to put it, default is usr/bin/<execName>+ , 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})
+ src/Debian/Debianize/Types/Base.hs view
@@ -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'))
+ src/Debian/Debianize/Types/BinaryDebDescription.hs view
@@ -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+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package>+ , _packageType :: Maybe PackageType+ , _architecture :: Maybe PackageArchitectures+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Architecture>+ , _binarySection :: Maybe Section+ , _binaryPriority :: Maybe PackagePriority+ , _essential :: Maybe Bool+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Essential>+ , _description :: Maybe Text+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Description>+ , _relations :: PackageRelations+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.6.10>+ } 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])
+ src/Debian/Debianize/Types/SourceDebDescription.hs view
@@ -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+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Source>+ , _maintainer :: Maybe NameAddr+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Maintainer>+ , _changedBy :: Maybe NameAddr+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Changed-By>+ , _uploaders :: [NameAddr]+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Uploaders>+ , _dmUploadAllowed :: Bool+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-DM-Upload-Allowed>+ , _priority :: Maybe PackagePriority+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Priority>+ , _section :: Maybe Section+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Section>+ , _standardsVersion :: Maybe StandardsVersion+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Standards-Version>+ , _homepage :: Maybe Text+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Homepage>+ , _vcsFields :: Set VersionControlSpec+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-VCS-fields>+ , _xFields :: Set XField+ -- ^ <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s5.7>+ , _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])
− src/Debian/Debianize/Types/VersionSplits.hs
@@ -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 = []}) ]
− src/Debian/Debianize/Utility.hs
@@ -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)
src/Debian/Debianize/VersionSplits.hs view
@@ -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 = []}) ]
src/Debian/Policy.hs view
@@ -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