cabal-debian 4.23.1 → 4.24.3

raw patch · 68 files changed

+5171/−683 lines, 68 filesdep +HaXmldep +bzlibdep +lensdep −data-lensdep −data-lens-templatedep ~debiandep ~parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: HaXml, bzlib, lens, zlib

Dependencies removed: data-lens, data-lens-template

Dependency ranges changed: debian, parsec

API changes (from Hackage documentation)

Files

• CabalDebian.hs +3/−2
• Tests.hs +75/−74
• cabal-debian.cabal +125/−81
• changelog +49/−0
• debian-haskell/Debian/Apt/Dependencies.hs +281/−0
• debian-haskell/Debian/Apt/Index.hs +300/−0
• debian-haskell/Debian/Apt/Methods.hs +486/−0
• debian-haskell/Debian/Apt/Package.hs +54/−0
• debian-haskell/Debian/Arch.hs +54/−0
• debian-haskell/Debian/Changes.hs +350/−0
• debian-haskell/Debian/Control.hs +74/−0
• debian-haskell/Debian/Control/ByteString.hs +270/−0
• debian-haskell/Debian/Control/Common.hs +191/−0
• debian-haskell/Debian/Control/Policy.hs +180/−0
• debian-haskell/Debian/Control/String.hs +110/−0
• debian-haskell/Debian/Control/Text.hs +154/−0
• debian-haskell/Debian/Deb.hs +24/−0
• debian-haskell/Debian/Extra/Files.hs +31/−0
• debian-haskell/Debian/GenBuildDeps.hs +291/−0
• debian-haskell/Debian/Loc.hs +23/−0
• debian-haskell/Debian/Pretty.hs +46/−0
• debian-haskell/Debian/Relation.hs +25/−0
• debian-haskell/Debian/Relation/ByteString.hs +30/−0
• debian-haskell/Debian/Relation/Common.hs +132/−0
• debian-haskell/Debian/Relation/String.hs +139/−0
• debian-haskell/Debian/Relation/Text.hs +30/−0
• debian-haskell/Debian/Release.hs +60/−0
• debian-haskell/Debian/Report.hs +87/−0
• debian-haskell/Debian/Sources.hs +171/−0
• debian-haskell/Debian/Time.hs +24/−0
• debian-haskell/Debian/URI.hs +90/−0
• debian-haskell/Debian/UTF8.hs +26/−0
• debian-haskell/Debian/Util/FakeChanges.hs +256/−0
• debian-haskell/Debian/Version.hs +15/−0
• debian-haskell/Debian/Version/ByteString.hs +18/−0
• debian-haskell/Debian/Version/Common.hs +181/−0
• debian-haskell/Debian/Version/Internal.hs +36/−0
• debian-haskell/Debian/Version/String.hs +25/−0
• debian-haskell/Debian/Version/Text.hs +18/−0
• debian/Debianize.hs +17/−17
• debian/changelog +29/−0
• src/Debian/Debianize.hs +0/−1
• src/Debian/Debianize/BasicInfo.hs +16/−19
• src/Debian/Debianize/BinaryDebDescription.hs +3/−2
• src/Debian/Debianize/BuildDependencies.hs +22/−34
• src/Debian/Debianize/CabalInfo.hs +22/−26
• src/Debian/Debianize/CopyrightDescription.hs +11/−10
• src/Debian/Debianize/DebInfo.hs +112/−115
• src/Debian/Debianize/DebianName.hs +5/−4
• src/Debian/Debianize/Details.hs +1/−5
• src/Debian/Debianize/Files.hs +8/−7
• src/Debian/Debianize/Finalize.hs +147/−145
• src/Debian/Debianize/Goodies.hs +26/−25
• src/Debian/Debianize/InputCabal.hs +2/−1
• src/Debian/Debianize/InputDebian.hs +27/−18
• src/Debian/Debianize/Monad.hs +2/−1
• src/Debian/Debianize/Options.hs +46/−43
• src/Debian/Debianize/Output.hs +11/−10
• src/Debian/Debianize/Prelude.hs +4/−3
• src/Debian/Debianize/SourceDebDescription.hs +2/−2
• src/Debian/Debianize/SubstVars.hs +7/−6
• src/Debian/GHC.hs +19/−3
• src/Debian/Orphans.hs +8/−2
• src/Debian/Policy.hs +1/−0
• src/OldLens.hs +65/−0
• test-data/alex/output/debian/changelog +1/−1
• test-data/artvaluereport2/input/debian/Debianize.hs +23/−24
• test-data/artvaluereport2/output/debian/control +0/−2

@@ -7,8 +7,9 @@ -- be accessed using the command line interface.  import Control.Category ((.))+import Control.Lens (view)+import Control.Monad.State (get) import Control.Monad.Trans (MonadIO, liftIO)-import Data.Lens.Lazy (access) import Data.List as List (unlines) import Debian.Debianize.BasicInfo (DebAction(Debianize, SubstVar, Usage), debAction, newFlags) import Debian.Debianize.CabalInfo (newCabalInfo, debInfo)@@ -33,7 +34,7 @@     -- taking.  Much of this will be repeated in the call to debianize.     do atoms <- liftIO $ newFlags >>= newCabalInfo        evalCabalT (do debianize init-                      action <- access (debAction . flags . debInfo)+                      action <- get >>= return . view (debInfo . flags . debAction)                       finish action) atoms     where       finish :: forall m. (MonadIO m, Functor m) => DebAction -> CabalT m ()

@@ -5,12 +5,12 @@     , main     ) where +import OldLens (getL, setL)+ import Control.Applicative ((<$>))-import Control.Category ((.)) import Data.Algorithm.Diff.Context (contextDiff) import Data.Algorithm.Diff.Pretty (prettyDiff) import Data.Function (on)-import Data.Lens.Lazy (getL, setL) import Data.List (sortBy) import Data.Map as Map (differenceWithKey, intersectionWithKey) import qualified Data.Map as Map (elems, Map, toList)@@ -34,14 +34,14 @@ import Debian.Debianize.Prelude ((%=), (++=), (+=), (~=), withCurrentDirectory) import qualified Debian.Debianize.SourceDebDescription as S import Debian.Debianize.VersionSplits (DebBase(DebBase))-import Debian.Pretty (ppDisplay)+import Debian.Pretty (ppShow) import Debian.Policy (databaseDirectory, PackageArchitectures(All), PackagePriority(Extra), parseMaintainer, Section(MainSection), SourceFormat(Native3), StandardsVersion(..), getDebhelperCompatLevel, getDebianStandardsVersion, License(..)) import Debian.Relation (BinPkgName(..), Relation(..), SrcPkgName(..), VersionReq(..)) import Debian.Release (ReleaseName(ReleaseName, relName)) import Debian.Version (parseDebianVersion, buildDebianVersion) import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Package (PackageName(PackageName))-import Prelude hiding (log, (.))+import Prelude hiding (log) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((</>)) import System.Process (readProcessWithExitCode)@@ -65,7 +65,7 @@ testAtoms = newFlags >>= newCabalInfo >>= return . ghc763     where       ghc763 :: CabalInfo -> CabalInfo-      ghc763 atoms = setL (compilerFlavor . D.flags . A.debInfo) GHC atoms+      ghc763 atoms = setL (A.debInfo . D.flags . compilerFlavor) GHC atoms  -- | Create a Debianization based on a changelog entry and a license -- value.  Uses the currently installed versions of debhelper and@@ -73,17 +73,17 @@ newDebianization :: Monad m => ChangeLog -> Maybe Int -> Maybe StandardsVersion -> CabalT m () newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry" newDebianization (log@(ChangeLog (entry : _))) level standards =-    do (D.changelog . A.debInfo) ~= Just log-       (D.compat . A.debInfo) ~= level-       (S.source . D.control . A.debInfo) ~= Just (SrcPkgName (logPackage entry))-       (S.maintainer . D.control . A.debInfo) ~= either error Just (parseMaintainer (logWho entry))-       (S.standardsVersion . D.control . A.debInfo) ~= standards+    do (A.debInfo . D.changelog) ~= Just log+       (A.debInfo . D.compat) ~= level+       (A.debInfo . D.control . S.source) ~= Just (SrcPkgName (logPackage entry))+       (A.debInfo . D.control . S.maintainer) ~= either error Just (parseMaintainer (logWho entry))+       (A.debInfo . D.control . S.standardsVersion) ~= standards newDebianization _ _ _ = error "Invalid changelog"  newDebianization' :: Monad m => Maybe Int -> Maybe StandardsVersion -> CabalT m () newDebianization' level standards =-    do (D.compat . A.debInfo) ~= level-       (S.standardsVersion . D.control . A.debInfo) ~= standards+    do (A.debInfo . D.compat) ~= level+       (A.debInfo . D.control . S.standardsVersion) ~= standards  tests :: Test tests = TestLabel "Debianization Tests" (TestList [-- 1 and 2 do not input a cabal package - we're not ready to@@ -105,9 +105,9 @@     TestLabel label $     TestCase (withCurrentDirectory "test-data/alex/input" $               do atoms <- testAtoms-                 actual <- evalCabalT (do (D.changelog . A.debInfo) ~= Just (ChangeLog [testEntry])-                                          (D.compat . A.debInfo) ~= Just 9-                                          (D.official . A.debInfo) ~= True+                 actual <- evalCabalT (do (A.debInfo . D.changelog) ~= Just (ChangeLog [testEntry])+                                          (A.debInfo . D.compat) ~= Just 9+                                          (A.debInfo . D.official) ~= True                                           Map.toList <$> liftCabal debianizationFileMap) atoms                  assertEqual label                    []@@ -237,8 +237,8 @@           execCabalM             (do defaultAtoms                 newDebianization log (Just 7) (Just (StandardsVersion 3 9 4 Nothing))-                (D.sourceFormat . debInfo) ~= Just Native3-                (D.rulesHead . debInfo) ~=+                (debInfo . D.sourceFormat) ~= Just Native3+                (debInfo . D.rulesHead) ~=                                Just (Text.unlines  ["#!/usr/bin/make -f",                                                     "# -*- makefile -*-",                                                     "",@@ -283,20 +283,20 @@                                                     "\trm -f $(manpages)",                                                     "",                                                     ""])-                (D.compat . debInfo) ~= Just 7-                (D.copyright . debInfo) %= (Just . id . fromMaybe (readCopyrightDescription "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"))-                (S.source . D.control . debInfo) ~= Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"})-                (S.maintainer . D.control . debInfo) ~= Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"})-                (S.uploaders . D.control . debInfo) ~= [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}]-                (S.priority . D.control . debInfo) ~= Just Extra-                (S.section . D.control . debInfo) ~= Just (MainSection "haskell")-                (S.buildDepends . D.control . debInfo) %= (++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]])-                (S.buildDependsIndep . D.control . debInfo) %=  (++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]])-                (S.standardsVersion . D.control . debInfo) ~= Just (StandardsVersion 3 9 4 Nothing)-                (S.vcsFields . D.control . debInfo) %= Set.union (Set.fromList [ S.VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts"+                (debInfo . D.compat) ~= Just 7+                (debInfo . D.copyright) %= (Just . id . fromMaybe (readCopyrightDescription "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"))+                (debInfo . D.control . S.source) ~= Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"})+                (debInfo . D.control . S.maintainer) ~= Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"})+                (debInfo . D.control . S.uploaders) ~= [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}]+                (debInfo . D.control . S.priority) ~= Just Extra+                (debInfo . D.control . S.section) ~= Just (MainSection "haskell")+                (debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]])+                (debInfo . D.control . S.buildDependsIndep) %=  (++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]])+                (debInfo . D.control . S.standardsVersion) ~= Just (StandardsVersion 3 9 4 Nothing)+                (debInfo . D.control . S.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"])-                (B.architecture . D.binaryDebDescription (BinPkgName "haskell-devscripts") . debInfo)  ~= Just All-                (B.description . D.binaryDebDescription (BinPkgName "haskell-devscripts") . debInfo) ~=+                (debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.architecture)  ~= Just All+                (debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.description) ~=                    Just                      (intercalate "\n"   ["Tools to help Debian developers build Haskell packages",                                           " This package provides a collection of scripts to help build Haskell",@@ -308,7 +308,7 @@                                           " 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.depends . B.relations . D.binaryDebDescription (BinPkgName "haskell-devscripts") . debInfo) ~=+                (debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.relations . B.depends) ~=                      [ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing]                      , [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing]                      , [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing]@@ -392,7 +392,7 @@                  atoms <- withCurrentDirectory inTop $ testAtoms                  old <- withCurrentDirectory outTop $ do                           execCabalT (liftCabal inputDebianization) atoms-                 let log = getL (D.changelog . debInfo) old+                 let log = getL (debInfo . D.changelog) old                  new <- withCurrentDirectory inTop $ do                           execCabalT (debianize (defaultAtoms >> customize log)) atoms                  diff <- diffDebianizations (getL debInfo old) (getL debInfo ({-copyFirstLogEntry old-} new))@@ -400,15 +400,15 @@     where       customize :: Maybe ChangeLog -> CabalT IO ()       customize log =-          do (D.changelog . debInfo) ~= log+          do (debInfo . D.changelog) ~= log              liftCabal tight              fixRules              doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups"              doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production"))-             (D.revision . A.debInfo) ~= Nothing-             (D.missingDependencies . A.debInfo) += (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")-             (D.sourceFormat . debInfo) ~= Just Native3-             (S.homepage . D.control . debInfo) ~= Just "http://www.clckwrks.com/"+             (A.debInfo . D.revision) ~= Nothing+             (A.debInfo . D.missingDependencies) += (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")+             (A.debInfo . D.sourceFormat) ~= Just Native3+             (A.debInfo . D.control . S.homepage) ~= Just "http://www.clckwrks.com/"              newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing)) {-       customize log = modifyM (lift . customize' log)@@ -430,7 +430,7 @@       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 =-          (D.rulesSettings . debInfo) %= (++ ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups"])+          (debInfo . D.rulesSettings) %= (++ ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups"]) {-           mapAtoms f deb           where@@ -474,7 +474,7 @@                      ]                  , D.installFile =                      D.InstallFile { D.execName   = "clckwrks-dot-com-server"-                                   , D.destName   = ppDisplay deb+                                   , D.destName   = ppShow deb                                    , D.sourceDir  = Nothing                                    , D.destDir    = Nothing }                  }@@ -499,41 +499,41 @@                      outTop = "test-data/creativeprompts/output"                  atoms <- withCurrentDirectory inTop testAtoms                  old <- withCurrentDirectory outTop $ newFlags >>= execDebianT inputDebianization . D.makeDebInfo-                 let standards = getL (S.standardsVersion . D.control) old+                 let standards = getL (D.control . S.standardsVersion) old                      level = getL D.compat old                  new <- withCurrentDirectory inTop (execCabalT (debianize (defaultAtoms >> customize old level standards)) atoms)                  diff <- diffDebianizations old (getL debInfo new)                  assertEqual label [] diff)     where       customize old level standards =-          do (D.utilsPackageNameBase . A.debInfo) ~= Just "creativeprompts-data"+          do (A.debInfo . D.utilsPackageNameBase) ~= Just "creativeprompts-data"              newDebianization' level standards-             (D.changelog . debInfo) ~= (getL D.changelog old)+             (debInfo . D.changelog) ~= (getL D.changelog old)              doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production"))              doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development"))              doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups"-             (D.execMap . A.debInfo) ++= ("trhsx", [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]])-             mapM_ (\ b -> (B.depends . B.relations . D.binaryDebDescription b . debInfo) %= \ deps -> deps ++ [[anyrel (BinPkgName "markdown")]])+             (A.debInfo . D.execMap) ++= ("trhsx", [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]])+             mapM_ (\ b -> (debInfo . D.binaryDebDescription b . B.relations . B.depends) %= \ deps -> deps ++ [[anyrel (BinPkgName "markdown")]])                    [(BinPkgName "creativeprompts-production"), (BinPkgName "creativeprompts-development")]-             (B.description . D.binaryDebDescription (BinPkgName "creativeprompts-development") . debInfo) ~=+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-development") . B.description) ~=                    Just (intercalate "\n" [ "Configuration for running the creativeprompts.com server"                                             , "  Testing version of the blog server, runs on port"                                             , "  8000 with HTML validation turned on." ])-             (B.description . D.binaryDebDescription (BinPkgName "creativeprompts-data") . debInfo) ~=+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-data") . B.description) ~=                    Just (intercalate "\n" [ "creativeprompts.com data files"                                             , "  Static data files for creativeprompts.com"])-             (B.description . D.binaryDebDescription (BinPkgName "creativeprompts-production") . debInfo) ~=+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-production") . B.description) ~=                    Just (intercalate "\n" [ "Configuration for running the creativeprompts.com server"                                             , "  Production version of the blog server, runs on port"                                             , "  9021 with HTML validation turned off." ])-             (B.description . D.binaryDebDescription (BinPkgName "creativeprompts-backups") . debInfo) ~=+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-backups") . B.description) ~=                    Just (intercalate "\n" [ "backup program for creativeprompts.com"                                             , "  Install this somewhere other than creativeprompts.com to run automated"                                             , "  backups of the database."])-             (B.architecture . D.binaryDebDescription (BinPkgName "creativeprompts-production") . debInfo) ~= Just All-             (B.architecture . D.binaryDebDescription (BinPkgName "creativeprompts-data") . debInfo) ~= Just All-             (B.architecture . D.binaryDebDescription (BinPkgName "creativeprompts-development") . debInfo) ~= Just All-             (D.sourceFormat . debInfo) ~= Just Native3+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-production") . B.architecture) ~= Just All+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-data") . B.architecture) ~= Just All+             (debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-development") . B.architecture) ~= Just All+             (debInfo . D.sourceFormat) ~= Just Native3        theSite :: BinPkgName -> D.Site       theSite deb =@@ -563,7 +563,7 @@                      ]                  , D.installFile =                      D.InstallFile { D.execName   = "creativeprompts-server"-                                 , D.destName   = ppDisplay deb+                                 , D.destName   = ppShow deb                                  , D.sourceDir  = Nothing                                  , D.destDir    = Nothing }                  }@@ -604,10 +604,10 @@     where       customize Nothing = error "Missing changelog"       customize (Just log) =-          do (S.buildDepends . D.control . debInfo) %= (++ [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]])-             (S.homepage . D.control . debInfo) ~= Just "http://artvaluereportonline.com"-             (D.sourceFormat . debInfo) ~= Just Native3-             (D.changelog . debInfo) ~= Just log+          do (debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]])+             (debInfo . D.control . S.homepage) ~= Just "http://artvaluereportonline.com"+             (debInfo . D.sourceFormat) ~= Just Native3+             (debInfo . D.changelog) ~= Just log              newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing))  test9 :: String -> Test@@ -616,14 +616,14 @@     TestCase (do let inTop = "test-data/alex/input"                      outTop = "test-data/alex/output"                  new <- withCurrentDirectory inTop $ newFlags >>= newCabalInfo >>= execCabalT (debianize (defaultAtoms >> customize))-                 let Just (ChangeLog (entry : _)) = getL (D.changelog . debInfo) new+                 let Just (ChangeLog (entry : _)) = getL (debInfo . D.changelog) new                  old <- withCurrentDirectory outTop $ newFlags >>= execDebianT (inputDebianization >> copyChangelogDate (logDate entry)) . D.makeDebInfo                  diff <- diffDebianizations old (getL debInfo new)                  assertEqual label [] diff)     where       customize =           do newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing))-             mapM_ (\ name -> (D.atomSet . debInfo) %= (Set.insert $ D.InstallData (BinPkgName "alex") name name))+             mapM_ (\ name -> (debInfo . D.atomSet) %= (Set.insert $ D.InstallData (BinPkgName "alex") name name))                    [ "AlexTemplate"                    , "AlexTemplate-debug"                    , "AlexTemplate-ghc"@@ -638,13 +638,14 @@                    , "AlexWrapper-posn"                    , "AlexWrapper-posn-bytestring"                    , "AlexWrapper-strict-bytestring"]-             (S.homepage . D.control . debInfo) ~= Just "http://www.haskell.org/alex/"-             (D.sourceFormat . debInfo) ~= Just Native3-             (D.debVersion . A.debInfo) ~= Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))+             (debInfo . D.control . S.homepage) ~= Just "http://www.haskell.org/alex/"+             (debInfo . D.sourceFormat) ~= Just Native3+             (debInfo . D.debVersion) ~= Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))              doExecutable (BinPkgName "alex")                           (D.InstallFile {D.execName = "alex", D.destName = "alex", D.sourceDir = Nothing, D.destDir = Nothing})-             -- Bootstrap dependency-             (S.buildDepends . D.control . debInfo) %= (++ [[Rel (BinPkgName "alex") Nothing Nothing]])+             -- Bootstrap self-dependency+             (debInfo . D.allowDebianSelfBuildDeps) ~= True+             (debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName "alex") Nothing Nothing]])  test10 :: String -> Test test10 label =@@ -659,15 +660,15 @@     where       customize :: CabalT IO ()       customize =-          do (D.sourceFormat . A.debInfo) ~= Just Native3-             (D.sourcePackageName . A.debInfo) ~= Just (SrcPkgName "seereason-darcs-backups")-             (D.compat . debInfo) ~= Just 5-             (S.standardsVersion . D.control . debInfo) ~= Just (StandardsVersion 3 8 1 Nothing)-             (S.maintainer . D.control . debInfo) ~= either (const Nothing) Just (parseMaintainer "David Fox <dsf@seereason.com>")-             (B.depends . B.relations . D.binaryDebDescription (BinPkgName "seereason-darcs-backups") . debInfo) %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]])-             (S.section . D.control . debInfo) ~= Just (MainSection "haskell")-             (D.utilsPackageNameBase . A.debInfo) ~= Just "seereason-darcs-backups"-             (D.atomSet . debInfo) %= (Set.insert $ D.InstallCabalExec (BinPkgName "seereason-darcs-backups") "seereason-darcs-backups" "/etc/cron.hourly")+          do (A.debInfo . D.sourceFormat) ~= Just Native3+             (A.debInfo . D.sourcePackageName) ~= Just (SrcPkgName "seereason-darcs-backups")+             (A.debInfo . D.compat) ~= Just 5+             (A.debInfo . D.control . S.standardsVersion) ~= Just (StandardsVersion 3 8 1 Nothing)+             (A.debInfo . D.control . S.maintainer) ~= either (const Nothing) Just (parseMaintainer "David Fox <dsf@seereason.com>")+             (A.debInfo . D.binaryDebDescription (BinPkgName "seereason-darcs-backups") . B.relations . B.depends) %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]])+             (A.debInfo . D.control . S.section) ~= Just (MainSection "haskell")+             (A.debInfo . D.utilsPackageNameBase) ~= Just "seereason-darcs-backups"+             (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec (BinPkgName "seereason-darcs-backups") "seereason-darcs-backups" "/etc/cron.hourly")  copyChangelogDate :: Monad m => String -> DebianT m () copyChangelogDate date =@@ -713,7 +714,7 @@                      (contextDiff 2 (split (== '\n') a) (split (== '\n') b))  sortBinaryDebs :: DebianT IO ()-sortBinaryDebs = (S.binaryPackages . D.control) %= sortBy (compare `on` getL B.package)+sortBinaryDebs = (D.control . S.binaryPackages) %= sortBy (compare `on` getL B.package)  main :: IO () main = runTestTT tests >>= putStrLn . show

@@ -1,5 +1,5 @@ Name:           cabal-debian-Version:        4.23.1+Version:        4.24.3 Copyright:      Copyright (c) 2007-2014, David Fox, Jeremy Shaw License:        BSD3 License-File:   LICENSE@@ -150,93 +150,137 @@   location: https://github.com/ddssff/cabal-debian  Library- Hs-Source-Dirs: src- GHC-Options: -Wall -O2- Build-Depends:-   base < 5,-   Cabal >= 1.9,-   containers,-   data-default,-   data-lens,-   data-lens-template,-   deepseq,-   Diff,-   directory,-   filepath,-   hsemail,-   HUnit,-   memoize,-   mtl,-   network-uri,-   parsec >= 3,-   pretty,-   prettyclass,-   process,-   pureMD5,-   regex-tdfa,-   set-extra,-   syb,-   text,-   unix,-   Unixutils,-   utf8-string- Exposed-Modules:-   Data.Algorithm.Diff.Context-   Data.Algorithm.Diff.Pretty-   Debian.Debianize-   Debian.GHC-   Debian.Policy-   Distribution.Version.Invert-   Debian.Debianize.BasicInfo-   Debian.Debianize.BinaryDebDescription-   Debian.Debianize.BuildDependencies-   Debian.Debianize.Bundled-   Debian.Debianize.CabalInfo-   Debian.Debianize.Changelog-   Debian.Debianize.CopyrightDescription-   Debian.Debianize.DebianName-   Debian.Debianize.DebInfo-   Debian.Debianize.Details-   Debian.Debianize.Files-   Debian.Debianize.Finalize-   Debian.Debianize.Goodies-   Debian.Debianize.InputCabal-   Debian.Debianize.InputDebian-   Debian.Debianize.Interspersed-   Debian.Debianize.Monad-   Debian.Debianize.Options-   Debian.Debianize.Output-   Debian.Debianize.Prelude-   Debian.Debianize.SourceDebDescription-   Debian.Debianize.SubstVars-   Debian.Debianize.VersionSplits-   Paths_cabal_debian- Other-Modules:-   Debian.Orphans- if flag(local-debian)-   Hs-Source-Dirs: debian-haskell-   Build-Depends: bytestring, exceptions, ListLike, network, network-uri, old-locale, process-extras, regex-compat, template-haskell, time- else-   Build-depends: debian >= 3.85+  Hs-Source-Dirs: src+  GHC-Options: -Wall -O2+  Build-Depends:+    base < 5,+    Cabal >= 1.9,+    containers,+    data-default,+    deepseq,+    Diff,+    directory,+    filepath,+    hsemail,+    HUnit,+    lens,+    memoize,+    mtl,+    network-uri,+    parsec >= 3,+    pretty,+    prettyclass,+    process,+    pureMD5,+    regex-tdfa,+    set-extra,+    syb,+    text,+    unix,+    Unixutils,+    utf8-string+  Exposed-Modules:+    Data.Algorithm.Diff.Context+    Data.Algorithm.Diff.Pretty+    Debian.GHC+    Debian.Policy+    Distribution.Version.Invert+    Debian.Debianize+    Debian.Debianize.BasicInfo+    Debian.Debianize.BinaryDebDescription+    Debian.Debianize.BuildDependencies+    Debian.Debianize.Bundled+    Debian.Debianize.CabalInfo+    Debian.Debianize.Changelog+    Debian.Debianize.CopyrightDescription+    Debian.Debianize.DebianName+    Debian.Debianize.DebInfo+    Debian.Debianize.Details+    Debian.Debianize.Files+    Debian.Debianize.Finalize+    Debian.Debianize.Goodies+    Debian.Debianize.InputCabal+    Debian.Debianize.InputDebian+    Debian.Debianize.Interspersed+    Debian.Debianize.Monad+    Debian.Debianize.Options+    Debian.Debianize.Output+    Debian.Debianize.Prelude+    Debian.Debianize.SourceDebDescription+    Debian.Debianize.SubstVars+    Debian.Debianize.VersionSplits+    OldLens+    Paths_cabal_debian+  Other-Modules:+    Debian.Orphans+  if flag(local-debian)+    Hs-Source-Dirs: debian-haskell+    Build-Depends:+      bytestring,+      bzlib,+      exceptions,+      HaXml,+      ListLike,+      network,+      network-uri,+      old-locale,+      process-extras,+      regex-compat,+      template-haskell,+      time,+      zlib+    Exposed-Modules:+      Debian.Apt.Dependencies,+      Debian.Apt.Index,+      Debian.Apt.Methods,+      Debian.Apt.Package,+      Debian.Arch,+      Debian.Changes,+      Debian.Control,+      Debian.Control.Common,+      Debian.Control.ByteString,+      Debian.Control.Policy,+      Debian.Control.String,+      Debian.Control.Text,+      Debian.Deb,+      Debian.Extra.Files,+      Debian.GenBuildDeps,+      Debian.Loc,+      Debian.Pretty,+      Debian.Relation,+      Debian.Relation.ByteString,+      Debian.Relation.Common,+      Debian.Relation.String,+      Debian.Relation.Text,+      Debian.Release,+      Debian.Sources,+      Debian.Version,+      Debian.Version.ByteString,+      Debian.Version.Common,+      Debian.Version.String,+      Debian.Version.Text,+      Debian.Report,+      Debian.Time,+      Debian.URI,+      Debian.UTF8,+      Debian.Util.FakeChanges+    Other-Modules:+      Debian.Version.Internal+  else+    Build-depends: debian >= 3.87  Executable cabal-debian  Hs-Source-Dirs: .  Main-is: CabalDebian.hs  ghc-options: -threaded -Wall -O2- Build-Depends: base, Cabal >= 1.9, data-lens, mtl, pretty- if flag(local-debian)-   Hs-Source-Dirs: src, debian-haskell-   Build-depends: bytestring, containers, data-default, data-lens-template, deepseq, Diff, directory, exceptions, filepath, hsemail, ListLike, memoize, network, network-uri, old-locale, parsec, prettyclass, process, process-extras, pureMD5, regex-compat, regex-tdfa, set-extra, syb, template-haskell, text, time, unix, Unixutils, utf8-string- else-   Build-depends: debian >= 3.85, cabal-debian+ Build-Depends: base, cabal-debian, Cabal >= 1.9, lens, mtl, pretty+ if !flag(local-debian)+   Build-Depends: debian >= 3.87  Executable cabal-debian-tests  Hs-Source-Dirs: .  Main-is: Tests.hs  ghc-options: -threaded -Wall -O2- Build-Depends: base, Cabal >= 1.9, containers, data-lens, filepath, hsemail, HUnit, prettyclass, process, text- if flag(local-debian)-   Hs-Source-Dirs: src, debian-haskell-   Build-depends: bytestring, containers, data-default, data-lens-template, deepseq, Diff, directory, exceptions, filepath, hsemail, ListLike, memoize, mtl, network, network-uri, old-locale, parsec, pretty, prettyclass, process, process-extras, pureMD5, regex-compat, regex-tdfa, set-extra, syb, template-haskell, text, time, unix, Unixutils, utf8-string- else-   Build-depends: debian >= 3.85, cabal-debian+ Build-Depends: base, cabal-debian, Cabal >= 1.9, containers, filepath, hsemail, HUnit, lens, prettyclass, process, text+ if !flag(local-debian)+   Build-Depends: debian >= 3.87

@@ -1,3 +1,52 @@+haskell-cabal-debian (4.24.3) unstable; urgency=low++  * Always include the test suite build dependencies in debian/control,+    even if the testEnabled flag is set to False (at the moment it seems+    as if it always is.)++ -- David Fox <dsf@seereason.com>  Mon, 02 Mar 2015 17:33:52 -0800++haskell-cabal-debian (4.24.2) unstable; urgency=low++  * Distinguish between the place we find the data files (dataTop) and the+    place we put then (dataDest)+  * Add a case for the ISC license++ -- David Fox <dsf@seereason.com>  Sun, 22 Feb 2015 15:09:56 -0800++haskell-cabal-debian (4.24.1) unstable; urgency=low++  * Don't assign the name "cabal-ghcjs" to newer Cabal library versions++ -- David Fox <dsf@seereason.com>  Sun, 22 Feb 2015 06:08:28 -0800++haskell-cabal-debian (4.24) unstable; urgency=low++  * Convert from old data-lens package to lens.+  * Implement --allow-debian-self-build-deps++ -- David Fox <dsf@seereason.com>  Sat, 14 Feb 2015 06:15:01 -0800++haskell-cabal-debian (4.23.1) unstable; urgency=low++  * ifdefs for Cabal-1.18, 1.20, and 1.22, ghc-7.6, and 7.8.++ -- David Fox <dsf@seereason.com>  Sun, 08 Feb 2015 23:21:07 -0800++haskell-cabal-debian (4.23) unstable; urgency=low++  * Add DEB_ENABLE_TESTS = yes to rules file when appropriate+  * Add test suite build dependencies when appropriate+  * Add --no-test-suite option+  * Add --allow-debian-self-build-deps+  * Filter out self dependencies in the debian package space, not the+    cabal package space.+  * Fix generation of machine readable debian/copyright files+  * Use the homepage value found in the cabal file+  * Add travis build file++ -- David Fox <dsf@seereason.com>  Fri, 06 Feb 2015 06:25:08 -0800+ haskell-cabal-debian (4.22) unstable; urgency=low    * Big module reorganization for more type safety.

@@ -0,0 +1,281 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -fno-warn-missing-signatures #-}+module Debian.Apt.Dependencies+{-+    ( solve+    , State +    , binaryDepends+    , search+    , bj'+    , bt+    , CSP(..)+    ) -} where++-- test gutsyPackages "libc6" (\csp -> bt csp)++import Control.Arrow (second)+import qualified Data.ByteString.Char8 as C+import Data.List as List (find, union)+import Data.Tree(Tree(rootLabel, Node))+import Debian.Apt.Package(PackageNameMap, packageNameMap, lookupPackageByRel)+import Debian.Control.ByteString(ControlFunctions(stripWS, lookupP, parseControlFromFile),+                                 Field'(Field, Comment), Control'(Control), Paragraph, Control)+import Debian.Relation (BinPkgName(..))+import Debian.Relation.ByteString(ParseRelations(..), Relation(..), OrRelation, AndRelation, Relations, checkVersionReq)+import Debian.Version(DebianVersion, parseDebianVersion, prettyDebianVersion)+import Text.PrettyPrint (render)++-- * Basic CSP Types and Functions++data Status +    = Remaining AndRelation+    | MissingDep Relation+    | Complete+      deriving (Eq)++type State a = (Status, [a])++complete :: State a -> Bool+complete (Complete, _) = True+complete _ = False++data CSP a+    = CSP { pnm :: PackageNameMap a+          , relations :: Relations+          , depFunction :: (a -> Relations)+          , conflicts :: a -> Relations+          , packageVersion :: a -> (BinPkgName, DebianVersion)+          }++-- * Test CSP++-- |TODO addProvides -- see DQL.Exec+controlCSP :: Control -> Relations -> (Paragraph -> Relations) -> CSP Paragraph+controlCSP (Control paragraphs) rels depF' =+    CSP { pnm = packageNameMap getName paragraphs+        , relations = rels+        , depFunction = depF'+        , conflicts = conflicts'+        , packageVersion = packageVersionParagraph+        }+    where+      getName :: Paragraph -> BinPkgName+      getName p = case lookupP "Package" p of+                    Nothing -> error "Missing Package field"+                    Just (Field (_,n)) -> BinPkgName (C.unpack (stripWS n))+                    Just (Comment _) -> error "controlCSP"+      conflicts' :: Paragraph -> Relations+      conflicts' p =+          case lookupP "Conflicts" p of+            Nothing -> []+            Just (Field (_, c)) -> either (error . show) id (parseRelations c)+            Just (Comment _) -> error "controlCSP"++testCSP :: FilePath -> (Paragraph -> Relations) -> String -> (CSP Paragraph -> IO a) -> IO a+testCSP controlFile depf relationStr cspf =+    do c' <- parseControlFromFile controlFile+       case c' of+         Left e -> error (show e)+         Right control@(Control _) ->+             case parseRelations relationStr of+               Left e -> error (show e)+               Right r ->+                     cspf (controlCSP control r depf)++depF :: Paragraph -> Relations+depF p =+    let preDepends =+            case lookupP "Pre-Depends" p of+              Nothing -> []+              Just (Field (_,pd)) -> +                  either (error . show) id (parseRelations pd)+              Just (Comment _) -> error "depF"+        depends =+            case lookupP "Depends" p of+              Nothing -> []+              Just (Field (_,pd)) -> +                  either (error . show) id (parseRelations pd)+              Just (Comment _) -> error "depF"+    in+      preDepends ++ depends++sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages"+gutsyPackages = "/var/lib/apt/lists/mirror.anl.gov_pub_ubuntu_dists_gutsy_main_binary-i386_Packages"++test controlFP rel labeler =+    testCSP controlFP depF rel (mapM_ (\ (_,p) -> mapM_ (print . second (render . prettyDebianVersion) . packageVersionParagraph) p ) . take 1 . search labeler)++-- TODO: add better errors+packageVersionParagraph :: Paragraph -> (BinPkgName, DebianVersion)+packageVersionParagraph p =+    case lookupP "Package" p of+      Nothing -> error $ "Paragraph missing Package field"+      (Just (Field (_, name))) ->+          case lookupP "Version" p of+            Nothing -> error $ "Paragraph missing Version field"+            (Just (Field (_, version))) -> (BinPkgName (C.unpack (stripWS name)), parseDebianVersion (C.unpack version))+            (Just (Comment _)) -> error "packageVersionParagraph"+      (Just (Comment _)) -> error "packageVersionParagraph"++++conflict :: CSP p -> p -> p -> Bool+conflict csp p1 p2 =+    let (name1, version1) = (packageVersion csp) p1+        (name2, version2) = (packageVersion csp) p2+    in+      if name1 == name2+      then version1 /= version2+      else+        any (conflict' (name1, version1)) (concat $ (conflicts csp) p2) ||+        any (conflict' (name2, version2)) (concat $ (conflicts csp) p1)++-- |JAS: deal with 'Provides' (can a package provide more than one package?)+conflict' :: (BinPkgName, DebianVersion) -> Relation -> Bool+conflict' (pName, pVersion) (Rel pkgName mVersionReq _) =+    (pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion))++++-- * Tree Helper Functions++mkTree :: a -> [Tree a] -> Tree a+mkTree = Node++label :: Tree a -> a+label = rootLabel++initTree :: (a -> [a]) -> a -> Tree a+initTree f a = Node a (map (initTree f) (f a))++mapTree :: (a -> b) -> Tree a -> Tree b+mapTree = fmap++foldTree :: (a -> [b] -> b) -> Tree a -> b+foldTree f (Node a ts) = f a (map (foldTree f) ts)++zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c+zipTreesWith f (Node a ts) (Node b us) =+    Node (f a b) (zipWith (zipTreesWith f) ts us)++prune :: (a -> Bool) -> Tree a -> Tree a+prune p = foldTree f+    where f a ts = Node a (filter (not . p . label) ts)++leaves :: Tree a -> [a]+leaves = foldTree f+    where f leaf [] = [leaf]+          f _ ts = concat ts++inhTree :: (b -> a -> b) -> b -> Tree a -> Tree b+inhTree f b (Node a ts) = Node b' (map (inhTree f b') ts)+    where b' = f b a++distrTree :: (a -> [b]) -> b -> Tree a -> Tree b+distrTree  f b (Node a ts) = Node b (zipWith (distrTree f) (f a) ts)++-- * mkSearchTree++-- TODO: might want to leave markers about what relation we are satisfying?+mkSearchTree :: forall a. CSP a -> Tree (State a)+mkSearchTree csp =+    Node (Remaining (relations csp),[]) (andRelation ([],[]) (relations csp))+    where+      andRelation :: ([a],AndRelation) -> AndRelation -> [Tree (State a)]+      andRelation (candidates,[]) [] = [Node (Complete, candidates) []]+      andRelation (candidates,remaining) [] = andRelation (candidates, []) remaining+      andRelation (candidates, remaining) (x:xs) =+          orRelation (candidates, xs ++ remaining) x+      orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)]+      orRelation acc x =+          concat (fmap (relation acc) x)+      relation :: ([a],AndRelation) -> Relation -> [Tree (State a)]+      relation acc@(candidates,_) rel =+          let packages = lookupPackageByRel (pnm csp) (packageVersion csp) rel in+          case packages of+            [] -> [Node (MissingDep rel, candidates) []]+            _ -> map (package acc) packages+      package :: ([a],AndRelation) -> a -> Tree (State a)+      package (candidates, remaining) p =+          if ((packageVersion csp) p) `elem` (map (packageVersion csp) candidates)+          then if null remaining+               then Node (Complete, candidates) []+               else Node (Remaining remaining, candidates) (andRelation (candidates, []) remaining)+          else Node (Remaining remaining, (p : candidates)) (andRelation ((p : candidates), remaining) ((depFunction csp) p))+++-- |earliestInconsistency does what it sounds like+-- the 'reverse as' is because the vars are order high to low, but we+-- want to find the lowest numbered (aka, eariest) inconsistency ??+-- +earliestInconsistency :: CSP a -> State a -> Maybe ((BinPkgName, DebianVersion), (BinPkgName, DebianVersion))+earliestInconsistency _ (_,[]) = Nothing+earliestInconsistency _ (_,[_p]) = Nothing+earliestInconsistency csp (_,(p:ps)) =+    case find ((conflict csp) p) (reverse ps) of+      Nothing -> Nothing+      (Just conflictingPackage) -> Just ((packageVersion csp) p, (packageVersion csp) conflictingPackage)++-- * Conflict Set++-- | conflicting packages and relations that require non-existant packages+type ConflictSet = ([(BinPkgName, DebianVersion)],[Relation])++isConflict :: ConflictSet -> Bool+isConflict ([],[]) = False+isConflict _ = True++solutions :: Tree (State a, ConflictSet) -> [State a]+solutions = filter complete . map fst . leaves . prune (isConflict . snd)++type Labeler a = CSP a -> Tree (State a) -> Tree (State a, ConflictSet)++search :: Labeler a -> CSP a -> [State a]+search labeler csp = (solutions . (labeler csp) . mkSearchTree) csp++-- * Backtracking Labeler++bt :: Labeler a+bt csp = mapTree f+    where+      f s@(status,_) =+              case status of+                (MissingDep rel) -> (s, ([], [rel]))+                _ ->+                    (s,+                      case (earliestInconsistency csp) s of+                        Nothing -> ([],[])+                        Just (a,b) -> ([a,b], []))++-- * BackJumping Solver++{-|bj - backjumping labeler++If the node already has a conflict set, then leave it alone.++Otherwise, the conflictset for the node is the combination of the+conflict sets of its direct children.+-}+bj :: CSP p -> Tree (State p, ConflictSet) -> Tree (State p, ConflictSet)+bj csp = foldTree f+    where f (s, cs) ts+            | isConflict cs  = mkTree (s, cs) ts+--            | isConflict cs' = mkTree (s, cs') [] -- prevent space leak+            | otherwise = mkTree (s, cs') ts+            where cs' = +                      let set = combine csp (map label ts) [] in+                      set `seq` set -- prevent space leak++unionCS :: [ConflictSet] -> ConflictSet+unionCS css = foldr (\(c1, m1) (c2, m2) -> ((c1 `union` c2), (m1 `union` m2))) ([],[]) css++combine :: CSP p -> [(State p, ConflictSet)] -> [ConflictSet] -> ConflictSet+combine _ [] acc = unionCS acc+combine csp ((s,cs@(c,m)):ns) acc+    | (not (lastvar `elem` c)) && null m = cs+    | null c && null m = ([],[]) -- is this case ever used?+    | otherwise = combine csp ns ((c, m):acc)+    where lastvar = +              let (_,(p:_)) = s in (packageVersion csp) p++

@@ -0,0 +1,300 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}+module Debian.Apt.Index+    ( update+    , Fetcher+    , CheckSums(..)+    , Compression(..)+    , FileTuple+    , Size+    , controlFromIndex+    , controlFromIndex'+    , findContentsFiles+    , findIndexes+    , indexesInRelease+    , tupleFromFilePath+    ) where++import Control.Monad+import qualified Codec.Compression.GZip as GZip+import qualified Codec.Compression.BZip as BZip+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Digest.Pure.MD5 as MD5+import Data.Function+import Data.List as List (null, intercalate, sortBy, isSuffixOf, isPrefixOf)+import qualified Data.Map as M+import Data.Monoid ((<>))+import Data.Text as Text (Text, unpack, concat, lines, null, words)+import Data.Time+import Debian.Apt.Methods+import Debian.Control (formatControl)+import Debian.Control.ByteString+import Debian.Control.Common+import Debian.Control.Text (decodeControl)+import Debian.Release+import Debian.Sources+import Debian.URI+import System.Directory+import System.FilePath ((</>))+import System.Posix.Files+import System.FilePath (takeBaseName)+--import qualified System.Unix.Misc as Misc+import Text.ParserCombinators.Parsec.Error+import Text.PrettyPrint (render)+import Text.PrettyPrint.HughesPJClass (pPrint)++-- |Package indexes on the server are uncompressed or compressed with+-- gzip or bzip2. We do not know what will exist on the server until we+-- actually look. This type is used to mark the compression status of+-- what was actually found.+data Compression+    = BZ2 | GZ | Uncompressed+      deriving (Read, Show, Eq, Ord, Enum, Bounded)++data CheckSums +    = CheckSums { md5sum :: Maybe String+                , sha1   :: Maybe String+                , sha256 :: Maybe String+                }+      deriving (Read, Show, Eq)++-- |function-type for a function that downloads a file+-- The timestamp is optional. If the local file is as new or newer+-- than the remote copy, the download may be skipped.+--+-- A good choice might be a partially parameterized call to+-- 'Debian.Apt.Methods.fetch'+type Fetcher =+    URI ->		-- remote URI+    FilePath ->		-- local file name+    Maybe UTCTime ->	-- optional time stamp for local file+    IO Bool		-- True on success, False on failure++-- |update - similar to apt-get update++-- downloads the index files associated with a sources.list. The+-- downloaded index files will have the same basenames that apt-get uses+-- in \/var\/lib\/apt\/lists. You can almost use this function instead of+-- calling apt-get update. However there are a few key differences:+--  1. apt-get update also updates the binary cache files+--  2. apt-get update uses the partial directory and lock file in\ /var\/lib\/apt\/lists +--  3. apt-get update downloads the Release and Release.gpg files+update :: Fetcher -- ^ function that will do actually downloading+       -> FilePath -- ^ download indexes to the directory (must already exist)+       -> String -- ^ binary architecture+       -> [DebSource] -- ^ sources.list +       -> IO [Maybe (FilePath, Compression)] -- ^ (basename of index file, compression status)+update fetcher basePath arch sourcesList =+    mapM (uncurry $ fetchIndex fetcher) (map (\(uri, fp, _) -> (uri, (basePath </> fp))) (concatMap (indexURIs arch) sourcesList))++-- | download possibly compressed files+-- NOTE: index uri must not include the .bz2 or .gz extension+fetchIndex :: Fetcher -- ^ function that will do the actual fetch+           -> URI -- ^ remote URI of package index, without .bz2 or .gz extension+           -> FilePath -- ^ name to save downloaded file as, without .bz2 or .gz extension+           -> IO (Maybe (FilePath, Compression)) -- ^ (downloaded file name + extension, compression status)+fetchIndex fetcher uri localPath =+    do let localPath' = localPath ++ ".bz2"+       --lm <- getLastModified localPath'+       res <- fetcher (uri { uriPath = (uriPath uri) ++ ".bz2" }) localPath' Nothing+       if res+          then return $ Just (localPath', BZ2)+          else do let localPath' = localPath ++ ".gz"+                  lm <- getLastModified localPath'+                  res <- fetcher (uri { uriPath = (uriPath uri) ++ ".gz" }) localPath' lm+                  if res+                     then return $ Just (localPath', GZ)+                     else do lm <- getLastModified localPath+                             res <- fetcher (uri { uriPath = (uriPath uri) }) localPath lm+                             if res+                                then return (Just (localPath, Uncompressed))+                                else return Nothing++-- |examine a DebSource line, and calculate for each section:+--  - the URI to the uncompressed index file+--  - the basename that apt-get would name the downloaded index+-- FIXME: ExactPath dist will fail with error at runtime :(+indexURIs :: String -- ^ which binary architecture+          -> DebSource -- ^ line from sources.list+          -> [(URI, FilePath, DebSource)] -- ^ (remote uri, local name, deb source for just this section)+indexURIs arch debSource =+    map (\ section -> let (uri, fp) = calcPath (sourceType debSource) arch baseURI release section+                      in (uri,fp, debSource { sourceDist = (Right (release, [section])) }) ) sections+    where+      baseURI = sourceUri debSource+      (release, sections) =+          either (error $ "indexURIs: support not implemented for exact path: " ++ render (pPrint debSource)) id (sourceDist debSource)++-- |return a tuple for the section +--  - the URI to the uncompressed index file+--  - the basename that apt-get uses for the downloaded index+-- FIXME: support for Release and Release.gpg+calcPath :: SourceType -- ^ do we want Packages or Sources+         -> String  -- ^ The binary architecture to use for Packages+         -> URI -- ^ base URI as it appears in sources.list+         -> ReleaseName -- ^ the release (e.g., unstable, testing, stable, sid, etc)+         -> Section -- ^ the section (main, contrib, non-free, etc)+         -> (URI, [Char]) -- ^ (uri to index file, basename for the downloaded file)+calcPath srcType arch baseURI release section =+          let indexPath = case srcType of+                      DebSrc -> "source/Sources"+                      Deb -> "binary-" ++ arch </> "Packages"+              path = (uriPath baseURI) </> "dists" </> (releaseName' release) </> sectionName' section </> indexPath+          in (baseURI { uriPath = path }, addPrefix . escapePath $ path)+          where+            addPrefix s = prefix scheme user' pass' reg port ++ {- "_" ++ -} s+            prefix "http:" (Just user) Nothing (Just host) port = user ++ host ++ port+            prefix "http:" _ _ (Just host) port = host ++ port+            prefix "ftp:" _ _ (Just host) _ = host+            prefix "file:" Nothing Nothing Nothing "" = ""+            prefix "ssh:" (Just user) Nothing (Just host) port = user ++ host ++ port+            prefix "ssh:" _ _ (Just host) port = host ++ port+            prefix _ _ _ _ _ = error ("calcPath: unsupported uri: " ++ uriToString' baseURI)+            user' = maybeOfString user+            pass' = maybeOfString pass+            (user, pass) = break (== ':') userpass+            userpass = maybe "" uriUserInfo auth+            reg = maybeOfString $ maybe "" uriRegName auth+            port = maybe "" uriPort auth+            scheme = uriScheme baseURI+            auth = uriAuthority baseURI+            --path = uriPath baseURI++            escapePath :: String -> String+            escapePath s = intercalate "_" $ wordsBy (== '/') s++            maybeOfString :: String -> Maybe String+            maybeOfString "" = Nothing+            maybeOfString s = Just s++            wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]+            wordsBy p s =+                case (break p s) of+                  (s, []) -> [s]+                  (h, t) -> h : wordsBy p (drop 1 t)++-- |Parse a possibly compressed index file.+controlFromIndex :: Compression -> FilePath -> L.ByteString -> Either ParseError (Control' Text)+controlFromIndex GZ path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . GZip.decompress $ s+controlFromIndex BZ2 path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks . BZip.decompress $ s+controlFromIndex Uncompressed path s = either Left (Right . decodeControl) . parseControl path . B.concat . L.toChunks $ s++-- |parse an index possibly compressed file+controlFromIndex' :: Compression -> FilePath -> IO (Either ParseError (Control' Text))+controlFromIndex' compression path = L.readFile path >>= return . controlFromIndex compression path++type Size = Integer+type FileTuple = (CheckSums, Size, FilePath)++-- |A release file contains a list of indexes (Packages\/Sources). Each+-- Package or Source index may appear multiple times because it may be+-- compressed several different ways. This function will return an+-- assoc list where the key is the name of the uncompressed package+-- index name and the value is the list of (file, compression) which+-- decompress to the key.+groupIndexes :: [FileTuple] -> [(FilePath, [(FileTuple, Compression)])]+groupIndexes indexFiles =+    M.toList $ M.fromListWith combine $ map makeKV indexFiles+    where+      makeKV fileTuple@(_,_,fp) =+          let (name, compressionMethod) = uncompressedName fp+          in+            (name, [(fileTuple, compressionMethod)])+      combine = (\x y -> sortBy (compare `on` snd) (x ++ y))+{-+      with t@(_,_,fp) m =+          let (un, compression) = +          in+            M.insertWith+-}++{-+groupIndexes' :: String ->[FileTuple] -> [(FilePath, [(FileTuple, Compression)])]+groupIndexes' iType indexFiles =+    M.toList (foldr (insertType iType) M.empty indexFiles)+    where+      insertType iType t@(_,_,fp) m =+          case uncompressedName' iType fp of+            Nothing -> m+            (Just (un, compression)) ->+                M.insertWith (\x y -> sortBy (compare `on` snd) (x ++ y)) un [(t, compression)] m+-}++-- |The release file contains the checksums for the uncompressed+-- package indexes, even if the uncompressed package indexes are not+-- stored on the server. This function returns the list of files that+-- actually exist.+filterExists :: FilePath -> (FilePath, [(FileTuple, Compression)]) -> IO (FilePath, [(FileTuple, Compression)])+filterExists distDir (fp, alternatives) =+          do e <- filterM ( \((_,_,fp),_) -> fileExist (distDir </> fp)) alternatives+             -- when (null e) (error $ "None of these files exist: " ++ show alternatives)+             return (fp, e)++findIndexes :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)]+findIndexes distDir iType controlFiles =+    let indexes = groupIndexes controlFiles+    in+      do indexes' <- mapM (filterExists distDir) (filter (isType iType) indexes)+         return $ map (head . snd) (filter (not . List.null . snd) indexes')+    where+      isType iType (fp, _) = iType `isSuffixOf` fp ++{-+findIndexes' :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)]+findIndexes' distDir iType controlFiles =+    let m = groupIndexes' iType controlFiles+    in+      do m' <- mapM (filterExists distDir) m+         return $ map (head . snd) (filter (not . null . snd) m')+-}++      -- insertType :: String -> (CheckSums, Integer, FilePath) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression)++{-+uncompressedName' :: String -> FilePath -> Maybe (FilePath, Compression)+uncompressedName' iType fp+          | isSuffixOf iType fp = Just (fp, Uncompressed)+          | isSuffixOf (iType ++".gz") fp = Just (reverse . (drop 3) . reverse $ fp, GZ)+          | isSuffixOf (iType ++".bz2") fp = Just (reverse . (drop 4) . reverse $ fp, BZ2)+          | otherwise = Nothing+-}++uncompressedName :: FilePath -> (FilePath, Compression)+uncompressedName fp+          | isSuffixOf ".gz"  fp = (reverse . (drop 3) . reverse $ fp, GZ)+          | isSuffixOf ".bz2" fp = (reverse . (drop 4) . reverse $ fp, BZ2)+          | otherwise            = (fp, Uncompressed)++indexesInRelease :: (FilePath -> Bool)+                 -> Control' Text -- ^ A release file+                 -> [(CheckSums, Integer, FilePath)] -- ^ +indexesInRelease filterp (Control [p]) =+    let md5sums =+            case md5sumField p of+              (Just md5) -> md5+              Nothing -> error $ "Did not find MD5Sum field."+    in+      filter (\(_,_,fp) -> filterp fp) $ map (makeTuple . Text.words) $ filter (not . Text.null) (Text.lines md5sums)+    where+      makeTuple :: [Text] -> (CheckSums, Integer, FilePath)+      makeTuple [md5sum, size, fp] = (CheckSums { md5sum = Just (Text.unpack md5sum), sha1 = Nothing, sha256 = Nothing }, read (Text.unpack size), Text.unpack fp)+      makeTuple x = error $ "Invalid line in release file: " ++ show x+indexesInRelease _ x = error $ "Invalid release file: " <> Text.unpack (Text.concat (formatControl x))++-- |make a FileTuple for a file found on the local disk+-- returns 'Nothing' if the file does not exist.+tupleFromFilePath :: FilePath -> FilePath -> IO (Maybe FileTuple)+tupleFromFilePath basePath fp =+          do e <- fileExist (basePath </> fp)+             if not e+              then return Nothing+              else do size <- getFileStatus (basePath </> fp) >>= return . fromIntegral . fileSize+                      md5 <- L.readFile (basePath </> fp) >>= return . show . MD5.md5+                      return $ Just (CheckSums { md5sum = Just md5, sha1 = Nothing, sha256 = Nothing }, size, fp)++-- |find the Contents-* files. These are not listed in the Release file+findContentsFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findContentsFiles filterP distDir =+          do files <- getDirectoryContents distDir+             return $ filter filterP $ filter (isPrefixOf "Contents-" . takeBaseName) files

@@ -0,0 +1,486 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-name-shadowing #-}+-- |an interface for using the methods in /var/lib/apt/methods+module Debian.Apt.Methods+    ( withMethodPath+    , withMethodURI+    , whichMethodPath+    , openMethod+    , closeMethod+    , recvStatus+    , sendCommand+    , getLastModified+    , simpleFetch+    , fetch+    , FetchCallbacks(..)+    , emptyFetchCallbacks+    , cliFetchCallbacks+    , Command(..)+    , Status(..)+    , Message, Site, User, Password, Media, Drive, Header, ConfigItem+    )+    where++import Debian.Time+import Debian.URI++import Control.Exception+import "mtl" Control.Monad.Error+import Data.Maybe+import Data.Time+import System.Directory+import System.Exit+import System.IO+import System.Posix.Files+import System.Process++type MethodHandle = (Handle, Handle, Handle, ProcessHandle)++capabilities, logMsg, status, uriStart, uriDone, uriFailure, generalFailure, authorizationRequired, mediaFailure, uriAcquire, configuration, authorizationCredentials, mediaChanged :: String+capabilities = "100"+logMsg = "101"+status = "102"+uriStart = "200"+uriDone = "201"+uriFailure = "400"+generalFailure = "401"+authorizationRequired = "402"+mediaFailure = "403"+uriAcquire = "600"+configuration = "601"+authorizationCredentials = "602"+mediaChanged = "603"++type Message = String+type Site = String+type User = String+type Password = String+type Media = String+type Drive = String++data Status+    = Capabilities { version :: String, singleInstance :: Bool, preScan :: Bool, pipeline :: Bool, sendConfig :: Bool+                   , needsCleanup :: Bool, localOnly :: Bool }+    | LogMsg Message+    | Status URI Message+    | URIStart { uri :: URI, size :: Maybe Integer, lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer }+    | URIDone { uri :: URI, size :: Maybe Integer,  lastModified :: Maybe UTCTime, resumePoint :: Maybe Integer+              , filename :: Maybe FilePath, hashes :: Hashes, imsHit :: Bool }+    | URIFailure { uri :: URI, message :: Message }+    | GeneralFailure Message+    | AuthorizationRequired Site+    | MediaFailure Media Drive+      deriving (Show, Eq)++data Hashes+    = Hashes { md5 :: Maybe String+             , sha1 :: Maybe String+             , sha256 :: Maybe String+             }+      deriving (Show, Eq)++emptyHashes = Hashes Nothing Nothing Nothing++data Command+    = URIAcquire URI FilePath (Maybe UTCTime)+    | Configuration [ConfigItem]+    | AuthorizationCredentials Site User Password+    | MediaChanged Media (Maybe Bool) -- I don't really understand the Fail field, I am assuming it is 'Fail: true'+      deriving (Show, Eq)++type Header = (String, String)+type ConfigItem = (String, String)++withMethodURI :: URI -> (MethodHandle -> IO a) -> IO a+withMethodURI uri f =+    do  mp <- liftM fromJust (whichMethodPath uri)+        withMethodPath mp f++-- |withMethod - run |methodPath| bracketed with+-- openMethod\/closeMethod. |f| gets the open handle.+withMethodPath :: FilePath -> (MethodHandle -> IO a) -> IO a+withMethodPath methodPath f =+    bracket (openMethod methodPath) closeMethod $ f++-- |whichMethodBinary - find the method executable associated with a URI+-- throws an exception on failure+whichMethodPath :: URI -> IO (Maybe FilePath)+whichMethodPath uri =+    let scheme = init (uriScheme uri)+        path = "/usr/lib/apt/methods/" ++ scheme+    in+      doesFileExist path >>= return . bool Nothing (Just path)++{-+The flow of messages starts with the method sending out a+100 Capabilities and APT sending out a 601 Configuration.++The flow is largely unsynchronized, but our function may have to+respond to things like authorization requests. Perhaps we do a+recvContents and then mapM_ over that ? Not all incoming messages+require a response, so...++-}++parseStatus :: [String] -> Status+parseStatus [] = error "parseStatus"+parseStatus (code' : headers') =+    parseStatus' (take 3 code') (map parseHeader headers')+    where+      parseStatus' code headers+          | code == capabilities =+              foldr updateCapability defaultCapabilities headers+                  where+                    updateCapability (a,v) c+                        | a == "Version"         = c { version = v }+                        | a == "Single-Instance" = c { singleInstance = parseTrueFalse v }+                        | a == "Pre-Scan"        = c { preScan = parseTrueFalse v }+                        | a == "Pipeline"        = c { pipeline = parseTrueFalse v }+                        | a == "Send-Config"     = c { sendConfig = parseTrueFalse v }+                        | a == "Needs-Cleanup"   = c { needsCleanup = parseTrueFalse v }+                        | a == "Local-Only"	 = c { localOnly = parseTrueFalse v }+                        | otherwise = error $ "unknown capability: " ++ show (a,v)+                    defaultCapabilities =+                        Capabilities { version = ""+                                     , singleInstance = False+                                     , preScan 	      = False+                                     , pipeline	      = False+                                     , sendConfig     = False+                                     , needsCleanup   = False+                                     , localOnly      = False+                                     }+      parseStatus' code headers+          | code == logMsg =+              case headers of+                [("Message", msg)] -> LogMsg msg+                _ -> error "parseStatus'"+          | code == status =+                Status (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers)+          | code == uriStart =+              foldr updateUriStart (URIStart undefined Nothing Nothing Nothing) headers+                  where+                    updateUriStart (a,v) u+                        | a == "URI" = u { uri = fromJust $ parseURI v }+                        | a == "Size" = u { size = Just (read v) }+                        | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ?+                        | a == "Resume-Point" = u { resumePoint = Just (read v) }+                    updateUriStart _ _ = error "updateUriStart"+      parseStatus' code headers+          | code == uriDone =+              foldr updateUriDone (URIDone undefined Nothing Nothing Nothing Nothing emptyHashes False) headers+                  where+                    updateUriDone (a,v) u+                        | a == "URI" = u { uri = fromJust $ parseURI v }+                        | a == "Size" = u { size = Just (read v) }+                        | a == "Last-Modified" = u { lastModified = parseTimeRFC822 v } -- if the date is unparseable, we silently truncate. Is that bad ?+                        | a == "Filename" = u { filename = Just v }+                        | a == "MD5Sum-Hash" = u { hashes = (hashes u) { md5    = Just v } }+                        | a == "MD5-Hash" = u { hashes = (hashes u) { md5    = Just v } }+                        | a == "SHA1-Hash"   = u { hashes = (hashes u) { sha1   = Just v } }+                        | a == "SHA256-Hash" = u { hashes = (hashes u) { sha256 = Just v } }+                        | a == "Resume-Point" = u { resumePoint = Just (read v) }+                        | a == "IMS-Hit" && v == "true" = u { imsHit = True }+                        | otherwise = error $ "updateUriDone: unknown header: " ++ show (a,v)+      parseStatus' code headers+          | code == uriFailure =+              URIFailure (fromJust $ parseURI $ fromJust $ lookup "URI" headers) (fromJust $ lookup "Message" headers)+          | code == generalFailure =+              GeneralFailure (fromJust $ lookup "Message" headers)+          | code == authorizationRequired =+              AuthorizationRequired (fromJust $ lookup "Site" headers)+          | code == mediaFailure =+              MediaFailure (fromJust $ lookup "Media" headers) (fromJust $ lookup "Drive" headers)+      parseStatus' _ _ = error "parseStatus'"++formatCommand :: Command -> [String]+formatCommand (URIAcquire uri filepath mLastModified) =+    [ uriAcquire ++ " URI Acquire"+    , "URI: " ++ uriToString' uri -- will this get credentials correct ? Or do we always pass those in seperately+    , "FileName: " ++ filepath+    ] ++ maybe [] (\lm -> ["Last-Modified: " ++ formatTimeRFC822 lm ]) mLastModified+formatCommand (Configuration configItems) =+    (configuration ++ " Configuration") : (map formatConfigItem configItems)+    where+      formatConfigItem (a,v) = concat ["Config-Item: ", a, "=", v]+formatCommand (AuthorizationCredentials site user passwd) =+    (authorizationCredentials ++ " Authorization Credentials") :+    [ "Site: " ++ site+    , "User: " ++ user+    , "Password: " ++ passwd+    ]+formatCommand (MediaChanged media mFail) =+    [ mediaChanged ++ " Media Changed"+    , "Media: " ++ media+    ] ++ maybe [] (\b -> ["Fail: " ++ case b of True -> "true" ; False -> "false"]) mFail+++parseTrueFalse :: String -> Bool+parseTrueFalse "true" = True+parseTrueFalse "false" = False+parseTrueFalse s = error $ "Invalid boolean string: " ++ s+++recvStatus :: MethodHandle -> IO Status+recvStatus mh = liftM parseStatus $ recv mh++sendCommand :: MethodHandle -> Command -> IO ()+sendCommand mh cmd = sendMethod mh (formatCommand cmd)+++parseHeader :: String -> Header+parseHeader str =+    let (a, r) = span (/= ':') str+        v = dropWhile (flip elem ": \t") r+    in+      (a, v)++openMethod :: FilePath -> IO MethodHandle+openMethod methodBinary =+    do+      -- hPutStrLn stderr ("openMethod " ++ methodBinary)+      runInteractiveCommand methodBinary+      -- runInteractiveProcess methodBinary [] Nothing Nothing++sendMethod :: MethodHandle -> [String] -> IO ()+sendMethod (pIn, _pOut, _, _) strings =+    do+      -- hPutStrLn stderr "send:"+      mapM_ put strings+      hPutStrLn pIn ""+      hFlush pIn+    where+      put line =+          do+            -- hPutStrLn stderr ("  " ++ line)+            hPutStrLn pIn line++closeMethod :: MethodHandle -> IO ExitCode+closeMethod (pIn, pOut, pErr, handle) =+    do+      -- hPutStrLn stderr "closeMethod"+      hClose pIn+      hClose pOut+      hClose pErr+      waitForProcess handle++recv :: MethodHandle -> IO [String]+recv (_pIn, pOut, _pErr, _pHandle) =+    do+      -- hPutStrLn stderr "recv:"+      readTillEmptyLine pOut+    where+      readTillEmptyLine pOut =+          do+            line <- hGetLine pOut+            case line of+              "" -> return []+              line ->+                  do+                    -- hPutStrLn stderr ("  " ++ line)+                    tail <- readTillEmptyLine pOut+                    return $ line : tail+{-+The flow of messages starts with the method sending out a+<em>100 Capabilities</> and APT sending out a <em>601 Configuration</>.++The flow is largely unsynchronized, but our function may have to+respond to things like authorization requests. Perhaps we do a+recvContents and then mapM_ over that ? Not all incoming messages+require a response.++We probably also need to track state, for example, if we are+pipelining multiple downloads and want to show seperate progress bars+for each download.++If someone wants to use fetch, they will need to provide methods to:++ 1. prompt for and provide authentication+ 2. show progress+ 3. show media change dialog+ 4. Show log messages+ 5. Show failures+ 6. Send Configuration++pipeline vs non-pipeline mode.+what if different methods are being used ?++when pipelining, we probably don't want to have too many pipelines to+the same server. Perhaps there can be a limit, and for non-pipelinable+methods, we set the limit to 1.++Each method can run in a seperate thread, since methods do not+interact with each other. In fact, each unique method+uri can be a+seperate thread. We can use a MVar to track the global max download+count. Perhaps we also want a per host throttle, since it is the host+connect that is likely to max out, not the access method.++Plan:++partition fetches by (host,method).+fork off threads for each (host, method).+Use MVar to throttle per host, and total connections++We don't know if a method supports pipelining until we connect atleast+once. So if we have a non-pipelined method, we might want to start+multiple streams. On the other hand, for something like a CDROM, that+will just cause the system to thrash.++cdrom, file, etc, don't have a host, so that is not a unique key then.+Pipelining on local methods is tricky, because it is hard to tell if+the local methods point to the same device or not.++Even though we have multiple threads, the interactor can view the+incoming Stream as a single Stream because all the events are tagged+with the URI (i think). But, sending commands involves a fancy+router. We could include a reference to corresponding command for each+stream.++For now, let's serialize the transfers, but allow pipeling for methods+that really allow pipelining.++-}++data FetchCallbacks+    = FetchCallbacks { logCB :: Message ->  IO ()+                     , statusCB :: URI -> Message -> IO ()+                     , uriStartCB :: URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> IO ()+                     , uriDoneCB ::  URI -> Maybe Integer -> Maybe UTCTime -> Maybe Integer -> Maybe FilePath -> Hashes -> Bool -> IO ()+                     , uriFailureCB :: URI -> Message -> IO ()+                     , generalFailureCB :: Message -> IO ()+                     , authorizationRequiredCB :: Site -> IO (Maybe (User, Password))+                     , mediaFailureCB :: Media -> Drive -> IO ()+                     , debugCB :: String -> IO ()+                     }++simpleFetch :: [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool+simpleFetch = fetch cliFetchCallbacks++-- |fetch a single item, show console output+-- see also: getLastModified+fetch :: FetchCallbacks -> [ConfigItem] -> URI -> FilePath -> Maybe UTCTime -> IO Bool+fetch cb configItems uri fp lastModified =+    do withMethodURI uri $ \mh ->+        do s <- recvStatus mh+           debugCB cb ("<- " ++ show s)+           sendCommand' mh (URIAcquire uri fp lastModified)+           loop mh+    where+      sendCommand' mh c =+          do mapM_ (debugCB cb . ("-> " ++)) (formatCommand c)+             sendCommand mh c+      loop mh =+          do r <- recvStatus mh+             case r of+               Capabilities {} ->+                   do unless (null configItems) (sendCommand' mh (Configuration configItems))+                      loop mh+               LogMsg m ->+                   do logCB cb m+                      loop mh+               Status uri m ->+                   do statusCB cb uri m+                      loop mh+               URIStart uri size lastModified resumePoint ->+                   uriStartCB cb uri size lastModified resumePoint >> loop mh+               URIDone uri size lastModified resumePoint filename hashes imsHit ->+                   uriDoneCB cb uri size lastModified resumePoint filename hashes imsHit >> return True+               URIFailure uri message ->+                   uriFailureCB cb uri message >> return False+               GeneralFailure m -> generalFailureCB cb m >> return False+               AuthorizationRequired site ->+                   do mCredentials <- authorizationRequiredCB cb site+                      case mCredentials of+                        Nothing -> return False -- FIXME: do we need a force close option for closeMethod ?+                        Just (user, passwd) ->+                            do sendCommand' mh (AuthorizationCredentials site user passwd)+                               loop mh+               MediaFailure media drive ->+                    do mediaFailureCB cb media drive+                       return False++-- |set of callbacks which do nothing.+-- suitable for non-interactive usage. In the case authorization is+-- required, no credentials will be supplied and the download should+-- abort.+emptyFetchCallbacks =+    FetchCallbacks { logCB = \ _m -> return ()+                   , statusCB = \ _uri _m -> return ()+                   , uriStartCB = \ _uri _size _lastModified _resumePoint -> return ()+                   , uriDoneCB = \ _uri _size _lastModified _resumePoint _filename _hashes _imsHit -> return ()+                   , uriFailureCB = \ _uri _message -> return ()+                   , generalFailureCB = \ _m -> return ()+                   , authorizationRequiredCB = \ _site -> return Nothing+                   , mediaFailureCB = \ _media _drive -> return ()+                   , debugCB = \ _m -> return ()+                   }++cliFetchCallbacks =+    emptyFetchCallbacks { statusCB = \uri m -> putStrLn $ uriToString' uri ++ " : " ++ m+                        , uriStartCB = \ uri _size lastModified _resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified+                        , uriDoneCB = \uri _size _lastModified _resumePoint _filename _hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.")+                        , uriFailureCB = \uri message -> hPutStrLn stderr $ "URI Failure: " ++ uriToString' uri ++ " : " ++ message+                        , generalFailureCB = \message -> hPutStrLn stderr $ "General Failure: " ++ message+                        , authorizationRequiredCB = \site ->+                                                    do putStrLn $ "Authorization Required for " ++ site+                                                       putStrLn "Username: " >> hFlush stdout+                                                       user <- getLine+                                                       putStrLn "Password: " >> hFlush stdout+                                                       passwd <- getLine -- TODO: write a getPasswd function which does not echo input+                                                       return (Just (user, passwd))+                        , mediaFailureCB = \media drive -> hPutStrLn stderr $ "Media Failure: media=" ++ media ++" drive="++ drive+                        , debugCB = \m -> print m+                        }++{-+    FetchCallbacks { logCB = \m -> hPutStrLn stderr m+                   , statusCB = \uri m -> putStrLn (show uri ++" : "++ m)+                   , uriStartCB = \uri+                   }++defaultAuthenticate site =+    do putStrLn $ "Authorization Required for " ++ site+       putStrLn "Username: " >> hFlush stdout+       user <- getLine+       putStrLn "Password: " >> hFlush stdout+       passwd <- getLine -- TODO: write a getPasswd function which does not echo input+       return (user, passwd)+-}++{-+    let itemsByHost = groupOn (regName . fst) items+    in+      do totalQSem <- newQSem 16 -- max number of streams allowed for+         forkIO+    where+      regName = fmap uriRegName . uriAuthority+      withQSem :: QSem -> IO a -> IO a+      withQSem qSem f = bracket (waitQSem qSem) (const $ signalQSem qSem) (const f)++uris = map (fromJust . parseURI) [ "http://n-heptane.com/whee"+                                 , "file:/one/two/three"+                                 , "ssh://jeremy:aoeu@n-heptane.com"+                                 , "cdrom:/one"+                                 ]+-}++-- * Misc Helper Functions++bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True = t+++getLastModified :: FilePath -> IO (Maybe UTCTime)+getLastModified fp =+    do e <- doesFileExist fp+       if e+          then getFileStatus fp >>= return . Just . epochTimeToUTCTime . modificationTime+          else return Nothing++{-+groupOn :: (Ord b) => (a -> b) -> [a] -> [[a]]+groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f)++on :: (a -> a -> b) -> (c -> a) -> c -> c -> b+on f g x y = f (g x) (g y)+-}

@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |Functions for dealing with source and binary packages in an abstract-way+module Debian.Apt.Package where++-- Standard GHC Modules++import qualified Data.Map as Map++-- Local Modules++import Debian.Version+import Debian.Relation++type PackageNameMap a = Map.Map BinPkgName [a]++-- |'packageNameMap' creates a map from a package name to all the versions of that package+-- NOTE: Provides are not included in the map+-- NOTE: the sort order is random -- this is perhaps a bug+-- see also: 'addProvides'+packageNameMap :: (a -> BinPkgName) -> [a] -> PackageNameMap a+packageNameMap getName packages = foldl (\m p -> Map.insertWith (++) (getName p) [p] m) Map.empty packages++-- |'addProvides' finds packages that Provide other packages and adds+-- them to the PackageNameMap. They will be adde to the end of the+-- list, so that real packages have 'higher priority' than virtual+-- packages.+-- NOTE: Does not check for duplication or multiple use+addProvides :: (p -> [BinPkgName]) -> [p] -> PackageNameMap p -> PackageNameMap p+addProvides providesf ps pnm =+    let provides = findProvides providesf ps in+    foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides++-- |'findProvides'+findProvides :: forall p. (p -> [BinPkgName]) -> [p] -> [(BinPkgName, p)]+findProvides providesf packages = foldl addProvides' [] packages+    where addProvides' :: [(BinPkgName, p)] -> p -> [(BinPkgName, p)]+          addProvides' providesList package =+              foldl (\pl pkgName -> (pkgName, package): pl) providesList (providesf package)++-- |'lookupPackageByRel' returns all the packages that satisfy the specified relation+-- TODO: Add architecture check+lookupPackageByRel :: PackageNameMap a -> (a -> (BinPkgName, DebianVersion)) -> Relation -> [a]+lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq _mArch) =+    case Map.lookup pkgName pm of+      Nothing -> []+      Just packages -> filter filterVer packages+    where filterVer p =+              case mVerReq of+                Nothing -> True+                Just _verReq ->+                    let (pName, pVersion) = packageVersionF p+                    in if pName /= pkgName+                       then False -- package is a virtual package, hence we can not do a version req+                       else checkVersionReq mVerReq (Just pVersion)

@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module Debian.Arch+    ( Arch(..)+    , ArchOS(..)+    , ArchCPU(..)+    , prettyArch+    , parseArch+    ) where++import Data.Data (Data)+import Data.Monoid ((<>))+import Data.Typeable (Typeable)+import Text.PrettyPrint (Doc, text)++data ArchOS = ArchOS String | ArchOSAny deriving (Eq, Ord, Read, Show, Data, Typeable)++prettyOS :: ArchOS -> Doc+prettyOS (ArchOS s) = text s+prettyOS ArchOSAny = text "any"++parseOS :: String -> ArchOS+parseOS "any" = ArchOSAny+parseOS s = ArchOS s++data ArchCPU = ArchCPU String | ArchCPUAny deriving (Eq, Ord, Read, Show, Data, Typeable)++prettyCPU :: ArchCPU -> Doc+prettyCPU (ArchCPU s) = text s+prettyCPU ArchCPUAny = text "any"++parseCPU :: String -> ArchCPU+parseCPU "any" = ArchCPUAny+parseCPU s = ArchCPU s++data Arch+    = Source+    | All+    | Binary ArchOS ArchCPU+    deriving (Eq, Ord, Read, Show, Data, Typeable)++prettyArch :: Arch -> Doc+prettyArch Source = text "source"+prettyArch All = text "all"+prettyArch (Binary (ArchOS "linux") cpu) = prettyCPU cpu+prettyArch (Binary os cpu) = prettyOS os <> text "-" <> prettyCPU cpu++parseArch :: String -> Arch+parseArch s =+    case span (/= '-') s of+      ("source", "") -> Source+      ("all", "") -> All+      (cpu, "") -> Binary (ArchOS "linux") (parseCPU cpu)+      (os, '-' : cpu) -> Binary (parseOS os) (parseCPU cpu)+      _ -> error "parseArch: internal error"

@@ -0,0 +1,350 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-missing-signatures #-}+-- |Changelog and changes file support.+module Debian.Changes+    ( ChangesFile(..)+    , ChangedFileSpec(..)+    , changesFileName+    , ChangeLog(..)+    , ChangeLogEntry(..)+    , parseChangeLog+    , parseEntries -- was parseLog+    , parseEntry+    , parseChanges+    ) where++import Data.Either (partitionEithers)+import Data.List (intercalate, intersperse)+import Data.Monoid ((<>))+import Data.Text (Text, pack, unpack, strip)+import Debian.Arch (Arch, prettyArch)+import qualified Debian.Control.String as S+import Debian.Pretty (PP(..))+import Debian.Release+import Debian.URI()+import Debian.Version+import System.Posix.Types+import Text.Regex.TDFA hiding (empty)+import Text.PrettyPrint (Doc, text, hcat, render)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))++-- |A file generated by dpkg-buildpackage describing the result of a+-- package build+data ChangesFile =+    Changes { changeDir :: FilePath		-- ^ The full pathname of the directory holding the .changes file.+            , changePackage :: String		-- ^ The package name parsed from the .changes file name+            , changeVersion :: DebianVersion	-- ^ The version number parsed from the .changes file name+            , changeRelease :: ReleaseName	-- ^ The Distribution field of the .changes file+            , changeArch :: Arch		-- ^ The architecture parsed from the .changes file name+            , changeInfo :: S.Paragraph' Text	-- ^ The contents of the .changes file+            , changeEntry :: ChangeLogEntry	-- ^ The value of the Changes field of the .changes file+            , changeFiles :: [ChangedFileSpec]	-- ^ The parsed value of the Files attribute+            } deriving (Eq, Read, Show)++-- |An entry in the list of files generated by the build.+data ChangedFileSpec =+    ChangedFileSpec { changedFileMD5sum :: String+                    , changedFileSHA1sum :: String+                    , changedFileSHA256sum :: String+                    , changedFileSize :: FileOffset+                    , changedFileSection :: SubSection+                    , changedFilePriority :: String+                    , changedFileName :: FilePath+                    } deriving (Eq, Read, Show)++-- |A changelog is a series of ChangeLogEntries+data ChangeLogEntry =+    Entry { logPackage :: String -- FIXME: Should be a SrcPkgName+          , logVersion :: DebianVersion+          , logDists :: [ReleaseName]+          , logUrgency :: String+          , logComments :: String+          , logWho :: String+          , logDate :: String+          }+  | WhiteSpace String -- ^ The parser here never returns this+  deriving (Eq, Read, Show)++newtype ChangeLog = ChangeLog [ChangeLogEntry] deriving (Eq, Read, Show)++{-+instance Show ChangesFile where+    show = changesFileName+-}++changesFileName :: ChangesFile -> String+changesFileName = render . pPrint . PP++instance Pretty (PP ChangesFile) where+    pPrint (PP changes) = text (changePackage changes ++ "_") <> prettyDebianVersion (changeVersion changes) <> text "_" <> prettyArch (changeArch changes) <> text ".changes"++instance Pretty (PP ChangedFileSpec) where+    pPrint (PP file) =+        text (changedFileMD5sum file <> " " <>+              show (changedFileSize file) <> " " <>+              sectionName (changedFileSection file) <> " " <>+              changedFilePriority file <> " " <>+              changedFileName file)++instance Pretty (PP ChangeLogEntry) where+    pPrint (PP (Entry package ver dists urgency details who date)) =+        hcat [ text package <> text " (" <> prettyDebianVersion ver <> text (") " <> intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency)+             , text "\n\n"+             , text "  " <> text (strip' details)+             , text "\n\n"+             , text (" -- " <> who <> "  " <> date)+             , text "\n" ]+    pPrint (PP (WhiteSpace _)) = error "instance Pretty ChangeLogEntry"++instance Pretty (PP [ChangeLogEntry]) where+    pPrint = hcat . intersperse (text "\n") . map (pPrint . PP) . unPP++strip' = unpack . strip . pack++instance Pretty (PP ChangeLog) where+    pPrint (PP (ChangeLog xs)) = hcat (intersperse (text "\n") (map (pPrint . PP) xs))++-- |Show just the top line of a changelog entry (for debugging output.)+_showHeader :: ChangeLogEntry -> Doc+_showHeader (Entry package ver dists urgency _ _ _) =+    text (package <> " (") <> prettyDebianVersion ver <> text (") " <> intercalate " " (map releaseName' dists) <> "; urgency=" <> urgency <> "...")+_showHeader (WhiteSpace _) = error "_showHeader"++{-+format is a series of entries like this:++     package (version) distribution(s); urgency=urgency+    [optional blank line(s), stripped]+       * change details+         more change details+    [blank line(s), included in output of dpkg-parsechangelog]+       * even more change details+    [optional blank line(s), stripped]+      -- maintainer name <email address>[two spaces]  date++package and version are the source package name and version number.++distribution(s) lists the distributions where this version should be+installed when it is uploaded - it is copied to the Distribution field+in the .changes file. See Distribution, Section 5.6.14.++urgency is the value for the Urgency field in the .changes file for+the upload (see Urgency, Section 5.6.17). It is not possible to+specify an urgency containing commas; commas are used to separate+keyword=value settings in the dpkg changelog format (though there is+currently only one useful keyword, urgency).++The change details may in fact be any series of lines starting with at+least two spaces, but conventionally each change starts with an+asterisk and a separating space and continuation lines are indented so+as to bring them in line with the start of the text above. Blank lines+may be used here to separate groups of changes, if desired.++If this upload resolves bugs recorded in the Bug Tracking System+(BTS), they may be automatically closed on the inclusion of this+package into the Debian archive by including the string: closes:+Bug#nnnnn in the change details.[16] This information is conveyed via+the Closes field in the .changes file (see Closes, Section 5.6.22).++The maintainer name and email address used in the changelog should be+the details of the person uploading this version. They are not+necessarily those of the usual package maintainer. The information+here will be copied to the Changed-By field in the .changes file (see+Changed-By, Section 5.6.4), and then later used to send an+acknowledgement when the upload has been installed.++The date must be in RFC822 format[17]; it must include the time zone+specified numerically, with the time zone name or abbreviation+optionally present as a comment in parentheses.++The first "title" line with the package name must start at the left+hand margin. The "trailer" line with the maintainer and date details+must be preceded by exactly one space. The maintainer details and the+date must be separated by exactly two spaces.++The entire changelog must be encoded in UTF-8. +-}++-- | Parse the entries of a debian changelog and verify they are all+-- valid.+parseChangeLog :: String -> ChangeLog+parseChangeLog s =+    case partitionEithers (parseEntries s) of+      ([], xs) -> ChangeLog xs+      (ss, _) -> error (intercalate "\n  " ("Error(s) parsing changelog:" : concat ss))++-- |Parse a Debian Changelog and return a lazy list of entries+parseEntries :: String -> [Either [String] ChangeLogEntry]+parseEntries "" = []+parseEntries text =+    case parseEntry text of+      Left messages -> [Left messages]+      Right (entry, text') -> Right entry : parseEntries text'++-- |Parse a single changelog entry, returning the entry and the remaining text.+{-+parseEntry :: String -> Failing (ChangeLogEntry, String)+parseEntry text =+    case span (\ x -> elem x " \t\n") text of+      ("", _) ->+          case matchRegexAll entryRE text of+            Nothing -> Failure ["Parse error in changelog:\n" ++ show text]+            Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) ->+                Success (Entry name +                               (parseDebianVersion version)+                               (map parseReleaseName . words $ dists)+                               urgency+			       details+                               who+                               date,+                         remaining)+            Just (before, _, remaining, submatches) ->+                Failure ["Internal error:\n  text=" ++ show text ++ "\n before=" ++ show before ++ "\n  remaining=" ++ show remaining ++ ", submatches=" ++ show submatches]+      (w, text') -> Success (WhiteSpace (trace ("whitespace: " ++ show w) w), text')+-}++parseEntry :: String -> Either [String] (ChangeLogEntry, String)+parseEntry text =+    case text =~ entryRE :: MatchResult String of+      x | mrSubList x == [] -> Left ["Parse error in " ++ show text]+      MR {mrAfter = after, mrSubList = [_, name, ver, dists, urgency, _, details, _, _, who, _, date, _]} ->+          Right (Entry name +                         (parseDebianVersion ver)+                         (map parseReleaseName . words $ dists)+                         urgency+			 ("  " ++ unpack (strip (pack details)) ++ "\n")+                         (take (length who - 2) who)+                         date,+                   after)+      MR {mrBefore = _before, mrMatch = _matched, mrAfter = after, mrSubList = matches} ->+          Left ["Internal error\n after=" ++ show after ++ "\n " ++ show (length matches) ++ " matches: " ++ show matches]+{-+parseREs :: [Regex] -> String -> Failing ([String], String)+parseREs res text =+    foldr f (Success ([], text)) entryREs+    where+      f _ (Failure msgs) = Failure msgs+      f re (Success (oldMatches, text)) =+          case matchRegexAll re text of+            Nothing -> Failure ["Parse error at " ++ show text]+            Just (before, matched, after, newMatches) ->+                Success (oldMatches ++ trace ("newMatches=" ++ show newMatches) newMatches, after)+-}++entryRE = bol ++ blankLines ++ headerRE ++ changeDetails ++ signature ++ blankLines+changeDetails = "((\n| \n| -\n|([^ ]| [^--]| -[^--])[^\n]*\n)*)"+signature = " -- ([ ]*([^ ]+ )* )([^\n]*)\n"++{-+entryRE = mkRegexWithOpts (bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines) False True+nonSigLines = "(((  .*|\t.*| \t.*)|([ \t]*)\n)+)"+-- In the debian repository, sometimes the extra space in front of the+-- day-of-month is missing, sometimes an extra one is added.+signature = "( -- ([^\n]*)  (..., ? ?.. ... .... ........ .....))[ \t]*\n"+-}++-- |Parse the changelog information that shows up in the .changes+-- file, i.e. a changelog entry with no signature.+parseChanges :: Text -> Maybe ChangeLogEntry+parseChanges text =+    case unpack text =~ changesRE :: MatchResult String of+      MR {mrSubList = []} -> Nothing+      MR {mrSubList = [_, name, ver, dists, urgency, _, details]} ->+          Just $ Entry name+                       (parseDebianVersion ver)+                       (map parseReleaseName . words $ dists)+                       urgency+		       details+                       "" ""+      MR {mrSubList = x} -> error $ "Unexpected match: " ++ show x+    where+      changesRE = bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$"++headerRE =+    package ++ ver ++ dists ++ urgency+    where+      package = "([^ \t(]*)" ++ optWhite+      ver = "\\(([^)]*)\\)" ++ optWhite+      dists = "([^;]*);" ++ optWhite+      urgency = "urgency=([^\n]*)\n" ++ blankLines++blankLines = blankLine ++ "*"+blankLine = "(" ++ optWhite ++ "\n)"+optWhite = "[ \t]*"+bol = "^"++-- This can be used for tests+_s1 = unlines+     ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low",+      "",+      "  [ Joachim Breitner ]",+      "  * Adjust priority according to override file",+      "  * Depend on hscolour (Closes: #550769)",+      "",+      "  [ Marco Túlio Gontijo e Silva ]",+      "  * debian/control: Use more sintetic name for Vcs-Darcs.",+      "  * Built from sid apt pool",+      "  * Build dependency changes:",+      "     cpphs:                    1.9-1+seereason1~jaunty5     -> 1.9-1+seereason1~jaunty6",+      "     ghc6:                     6.10.4-1+seereason5~jaunty1  -> 6.12.1-0+seereason1~jaunty1",+      "     ghc6-doc:                 6.10.4-1+seereason5~jaunty1  -> 6.12.1-0+seereason1~jaunty1",+      "     ghc6-prof:                6.10.4-1+seereason5~jaunty1  -> 6.12.1-0+seereason1~jaunty1",+      "     haddock:                  2.4.2-3+seereason3~jaunty1   -> 6.12.1-0+seereason1~jaunty1",+      "     haskell-devscripts:       0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1",+      "     haskell-regex-base-doc:   0.93.1-5+seereason1~jaunty1  -> 0.93.1-5++1+seereason1~jaunty1",+      "     haskell-regex-posix-doc:  0.93.2-4+seereason1~jaunty1  -> 0.93.2-4+seereason1~jaunty2",+      "     libghc6-regex-base-dev:   0.93.1-5+seereason1~jaunty1  -> 0.93.1-5++1+seereason1~jaunty1",+      "     libghc6-regex-base-prof:  0.93.1-5+seereason1~jaunty1  -> 0.93.1-5++1+seereason1~jaunty1",+      "     libghc6-regex-posix-dev:  0.93.2-4+seereason1~jaunty1  -> 0.93.2-4+seereason1~jaunty2",+      "     libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1  -> 0.93.2-4+seereason1~jaunty2",+      "",+      " -- SeeReason Autobuilder <autobuilder@seereason.org>  Fri, 25 Dec 2009 01:55:37 -0800",+      "",+      "haskell-regex-compat (0.92-3) unstable; urgency=low",+      "",+      "  [ Joachim Breitner ]",+      "  * Adjust priority according to override file",+      "  * Depend on hscolour (Closes: #550769)",+      "",+      "  [ Marco Túlio Gontijo e Silva ]",+      "  * debian/control: Use more sintetic name for Vcs-Darcs.",+      "",+      " -- Joachim Breitner <nomeata@debian.org>  Mon, 20 Jul 2009 13:05:35 +0200",+      "",+      "haskell-regex-compat (0.92-2) unstable; urgency=low",+      "",+      "  * Adopt package for the Debian Haskell Group",+      "  * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control",+      "    (Closes: #536473)",+      "",+      " -- Joachim Breitner <nomeata@debian.org>  Mon, 20 Jul 2009 12:05:40 +0200",+      "",+      "haskell-regex-compat (0.92-1.1) unstable; urgency=low",+      "",+      "  * Rebuild for GHC 6.10.",+      "  * NMU with permission of the author.",+      "",+      " -- John Goerzen <jgoerzen@complete.org>  Mon, 16 Mar 2009 10:12:04 -0500",+      "",+      "haskell-regex-compat (0.92-1) unstable; urgency=low",+      "",+      "  * New upstream release",+      "  * debian/control:",+      "    - Bump Standards-Version. No changes needed.",+      "",+      " -- Arjan Oosting <arjan@debian.org>  Sun, 18 Jan 2009 00:05:02 +0100",+      "",+      "haskell-regex-compat (0.91-1) unstable; urgency=low",+      "",+      "  * Take over package from Ian, as I already maintain haskell-regex-base,",+      "    and move Ian to the Uploaders field.",+      "  * Packaging complete redone (based on my haskell-regex-base package).",+      "",+      " -- Arjan Oosting <arjan@debian.org>  Sat, 19 Jan 2008 16:48:39 +0100",+      "",+      "haskell-regex-compat (0.71.0.1-1) unstable; urgency=low",+      " ",+      "  * Initial release (used to be part of ghc6).",+      "  * Using \"Generic Haskell cabal library packaging files v9\".",+      "  ",+      " -- Ian Lynagh (wibble) <igloo@debian.org>  Wed, 21 Nov 2007 01:26:57 +0000"]

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+-- |A module for working with Debian control files <http://www.debian.org/doc/debian-policy/ch-controlfields.html>+module Debian.Control +    ( -- * Types+      Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , Control+    , Paragraph+    , Field+    , ControlParser+    , ControlFunctions(..)+    -- * Control File Parser+    , pControl+    -- * Helper Functions+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    , packParagraph+    , packField+    , formatControl+    , formatParagraph+    , formatField+    -- * Policy classes and functions+    , P.HasDebianControl(..)+    , P.ControlFileError(..)+    , P.parseDebianControlFromFile+    , P.validateDebianControl+    , P.unsafeDebianControl+    , P.debianSourceParagraph+    , P.debianBinaryParagraphs+    , P.debianPackageParagraphs+    , P.debianPackageNames+    , P.debianSourcePackageName+    , P.debianBinaryPackageNames+    , P.debianRelations+    , P.debianBuildDeps+    , P.debianBuildDepsIndep+    ) where++--import Control.Monad+--import Data.List+--import Text.ParserCombinators.Parsec+--import System.IO+import Debian.Control.Common+import Debian.Control.String+import Data.List+import Data.Text as T (Text, pack, concat)+import qualified Debian.Control.Text as T+import qualified Debian.Control.ByteString as B ()+import qualified Debian.Control.Policy as P+import qualified Debian.Control.String as S++packParagraph :: S.Paragraph -> T.Paragraph+packParagraph (S.Paragraph s) = T.Paragraph (map packField s)++packField :: Field' String -> Field' Text+packField (S.Field (name, value)) = T.Field (T.pack name, T.pack value)+packField (S.Comment s) = T.Comment (T.pack s)++formatControl :: Control' Text -> [Text]+formatControl (T.Control paragraphs) = intersperse (T.pack "\n") . map formatParagraph $ paragraphs++formatParagraph :: Paragraph' Text -> Text+formatParagraph (T.Paragraph fields) = T.concat . map formatField $ fields++formatField :: Field' Text -> Text+formatField (T.Field (name, value)) = T.concat [name, T.pack ":", value, T.pack "\n"]+formatField (T.Comment s) = s

@@ -0,0 +1,270 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}+module Debian.Control.ByteString+    ( Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , Control+    , Paragraph+    , Field+    , ControlFunctions(..)+    -- * Helper Functions+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    ) where++-- Standard GHC modules++import qualified Control.Exception as E+import "mtl" Control.Monad.State++import Data.Char(toLower, isSpace, chr, ord)+import Data.Word (Word8)+import Data.List+import qualified Data.ListLike as LL+import qualified Data.ListLike.String as LL++import Text.ParserCombinators.Parsec.Error+import Text.ParserCombinators.Parsec.Pos++-- Third Party Modules++import qualified Data.ByteString.Char8 as C++import Debian.Control.Common hiding (protectFieldText')++-- Local Modules++-- import ByteStreamParser++-- * Types+{-+newtype Control = Control [Paragraph]+newtype Paragraph = Paragraph [Field]+newtype Field = Field (C.ByteString, C.ByteString)+-}++type Control = Control' C.ByteString+type Paragraph = Paragraph' C.ByteString+type Field = Field'  C.ByteString+-- * Control Parser++type ControlParser a = Parser C.ByteString a++pKey :: ControlParser C.ByteString+pKey = notEmpty $ pTakeWhile (\c -> (c /= ':') && (c /= '\n'))++pValue :: ControlParser C.ByteString+pValue = Parser $ \bs ->+    let newlines = C.elemIndices '\n' bs+        rest = dropWhile continuedAfter newlines ++ [C.length bs]+        continuedAfter i = bs `safeIndex` (i+1) `elem` map Just " \t#"+        (text, bs') = C.splitAt (head rest) bs+    in Ok (text, bs')++pField :: ControlParser Field+pField =+    do k <- pKey+       _ <- pChar ':'+       v <- pValue+--       pChar '\n'+       (pChar '\n' >> return ()) <|> pEOF+       return (Field (k,v))++pComment :: ControlParser Field+pComment = Parser $ \bs ->+    let newlines = C.elemIndices '\n' bs+        linestarts = 0 : map (+1) newlines+        rest = dropWhile commentAt linestarts ++ [C.length bs]+        commentAt i = bs `safeIndex` i == Just '#'+        (text, bs') = C.splitAt (head rest) bs+    in if C.null text+       then Empty+       else Ok (Comment text, bs')++pParagraph :: ControlParser Paragraph+pParagraph = +    do f <- pMany1 (pComment <|> pField)+       pSkipMany (pChar '\n')+       return (Paragraph f)++pControl :: ControlParser Control+pControl = +    do pSkipMany (pChar '\n')+       c <- pMany pParagraph+       return (Control c)+++-- parseControlFromFile :: FilePath -> IO (Either String Control)++instance ControlFunctions C.ByteString where+    parseControlFromFile fp = +        do c <- C.readFile fp+           case parse pControl c of+             Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0)))+             (Just (cntl,_)) -> return (Right cntl)+    parseControlFromHandle sourceName handle =+        E.try (C.hGetContents handle) >>=+        either (\ (e :: E.SomeException) -> error ("parseControlFromHandle ByteString: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName)+    parseControl sourceName c =+        do case parse pControl c of+             Nothing -> Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0))+             Just (cntl,_) -> Right cntl+    lookupP fieldName (Paragraph fields) =+        let pFieldName = C.pack (map toLower fieldName) in+        find (\ (Field (fieldName',_)) -> C.map toLower fieldName' == pFieldName) fields+    -- NOTE: probably inefficient+    stripWS = C.reverse . strip . C.reverse . strip+        where strip = C.dropWhile (flip elem " \t")+    protectFieldText = protectFieldText'+    asString = C.unpack++protectFieldText' :: (LL.StringLike a, LL.ListLike a Word8) => ControlFunctions a => a -> a+protectFieldText' s =+    case LL.lines s of+      [] -> LL.empty+      (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ LL.unlines $ l : map protect ls+    where+      dropWhileEnd :: (LL.StringLike a, LL.ListLike a Word8) => (Word8 -> Bool) -> a -> a+      dropWhileEnd func = LL.reverse . LL.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty+      protect :: (LL.StringLike a, LL.ListLike a Word8) => a -> a+      protect l = maybe LL.empty (\ c -> if isHorizSpace c then l else LL.cons (ord' ' ' :: Word8) l) (LL.find (const True :: Word8 -> Bool) l)+      isSpace' = isSpace . chr'+      isHorizSpace c = elem c (map ord' " \t")+      ord' = fromIntegral . ord+      chr' = chr . fromIntegral++{-+main = +    do [fp] <- getArgs+       C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c)+-}+-- * Helper Functions++safeIndex :: C.ByteString -> Int -> Maybe Char+bs `safeIndex` i = if i < C.length bs then Just (bs `C.index` i) else Nothing++-- * Parser++data Result a+    = Ok a+    | Fail+    | Empty+      deriving Show++-- m2r :: Maybe a -> Result a+-- m2r (Just a) = Ok a+-- m2r Nothing = Empty++r2m :: Result a -> Maybe a+r2m (Ok a) = Just a+r2m _ = Nothing++newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) }++instance Monad (Parser state) where+    return a = Parser (\s -> Ok (a,s))+    m >>= f =+        Parser $ \state ->+            let r = (unParser m) state in+            case r of+              Ok (a,state') -> +                  case unParser (f a) $ state' of+                    Empty -> Fail+                    o -> o+              Empty -> Empty+              Fail -> Fail++instance MonadPlus (Parser state) where+    mzero = Parser (const Empty)+    mplus (Parser p1) (Parser p2) =+        Parser (\s -> case p1 s of+                        Empty -> p2 s+                        o -> o+               )+        +--       Parser (\s -> maybe (p2 s) (Just) (p1 s))+++_pSucceed :: a -> Parser state a+_pSucceed = return++_pFail :: Parser state a+_pFail = Parser (const Empty)+++(<|>) :: Parser state a -> Parser state a -> Parser state a+(<|>) = mplus+++satisfy :: (Char -> Bool) -> Parser C.ByteString Char+satisfy f =+    Parser $ \bs ->+        if C.null bs+        then Empty+        else let (s,ss) = (C.head bs, C.tail bs) in+             if (f s)+                then Ok (s,ss)+                else Empty++pChar :: Char -> Parser C.ByteString Char+pChar c = satisfy ((==) c)+++_try :: Parser state a -> Parser state a+_try (Parser p) =+    Parser $ \bs -> case (p bs) of+                      Fail -> Empty+                      o -> o++pEOF :: Parser C.ByteString ()+pEOF =+    Parser $ \bs -> if C.null bs then Ok ((),bs) else Empty++pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString+pTakeWhile f =+    Parser $ \bs -> Ok (C.span f bs)++_pSkipWhile :: (Char -> Bool) -> Parser C.ByteString ()+_pSkipWhile p =+    Parser $ \bs -> Ok ((), C.dropWhile p bs)++pMany ::  Parser st a -> Parser st [a]+pMany p +    = scan id+    where+      scan f = do x <- p+                  scan (\tail -> f (x:tail))+               <|> return (f [])++notEmpty :: Parser st C.ByteString -> Parser st C.ByteString +notEmpty (Parser p) =+    Parser $ \s -> case p s of+                     o@(Ok (a, _s)) ->+                         if C.null a+                         then Empty+                         else o+                     x -> x++pMany1 :: Parser st a -> Parser st [a]+pMany1 p =+    do x <- p+       xs <- pMany p+       return (x:xs)++pSkipMany :: Parser st a -> Parser st ()+pSkipMany p = scan+    where+      scan = (p >> scan) <|> return ()+       +_pSkipMany1 :: Parser st a -> Parser st ()+_pSkipMany1 p = p >> pSkipMany p++parse :: Parser state a -> state -> Maybe (a, state)+parse p s = r2m ((unParser p) s)

@@ -0,0 +1,191 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, UndecidableInstances #-}+module Debian.Control.Common+    ( -- * Types+      Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , ControlFunctions(..)+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    , parseControlFromCmd+    , md5sumField+    , protectFieldText'+    )+    where++import Data.Char (isSpace)+import Data.List as List (dropWhileEnd, partition, intersperse)+import Data.ListLike as LL (ListLike, cons, dropWhileEnd, empty, find, null, singleton)+import Data.ListLike.String as LL (StringLike, lines, unlines)+import Data.Monoid ((<>))+import Debian.Pretty (PP(..))+import System.Exit (ExitCode(ExitSuccess, ExitFailure))+import System.IO (Handle)+import System.Process (runInteractiveCommand, waitForProcess)+import Text.ParserCombinators.Parsec (ParseError)+import Text.PrettyPrint (Doc, text, hcat)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))++newtype Control' a+    = Control { unControl :: [Paragraph' a] } deriving (Eq, Ord, Read, Show)++newtype Paragraph' a+    = Paragraph [Field' a]+    deriving (Eq, Ord, Read, Show)++-- |NOTE: we do not strip the leading or trailing whitespace in the+-- name or value+data Field' a+    = Field (a, a)+    | Comment a     -- ^ Lines beginning with #+      deriving (Eq, Ord, Read, Show)++class ControlFunctions a where+    -- |'parseControlFromFile' @filepath@ is a simple wrapper function+    -- that parses @filepath@ using 'pControl'+    parseControlFromFile :: FilePath -> IO (Either ParseError (Control' a))+    -- |'parseControlFromHandle' @sourceName@ @handle@ - @sourceName@ is only used for error reporting+    parseControlFromHandle :: String -> Handle -> IO (Either ParseError (Control' a))+    -- |'parseControlFromString' @sourceName@ @text@ - @sourceName@ is only used for error reporting+    parseControl :: String -> a -> (Either ParseError (Control' a))+    -- | 'lookupP' @fieldName paragraph@ looks up a 'Field' in a 'Paragraph'.+    -- @N.B.@ trailing and leading whitespace is /not/ stripped.+    lookupP :: String -> (Paragraph' a) -> Maybe (Field' a)+    -- |Strip the trailing and leading space and tab characters from a+    -- string. Folded whitespace is /not/ unfolded. This should probably+    -- be moved to someplace more general purpose.+    stripWS :: a -> a+    -- |Protect field value text so the parser doesn't split it into+    -- multiple fields or paragraphs.  This must modify all field text+    -- to enforce two conditions: (1) All lines other than the initial+    -- one must begin with a space or a tab, and (2) the trailing+    -- white space must not contain newlines.  This is called before+    -- pretty printing to prevent the parser from misinterpreting+    -- field text as multiple fields or paragraphs.+    protectFieldText :: a -> a+    asString :: a -> String++-- | This can usually be used as the implementation of protectFieldText+protectFieldText' :: forall a. (StringLike a, ListLike a Char) => ControlFunctions a => a -> a+protectFieldText' s =+    let trimmedLines :: [a]+        trimmedLines = map (LL.dropWhileEnd isSpace :: a -> a) $ (LL.lines s :: [a])+        strippedLines :: [a]+        strippedLines = List.dropWhileEnd LL.null trimmedLines in+    -- Split the text into lines, drop trailing whitespace from each+    -- line, and drop trailing blank lines.+    case strippedLines of+      [] -> empty+      (l : ls) ->+          let -- The first line is indented one space+              l' = {-LL.cons ' '-} l+              -- Null lines are replaced by a single '.'  If any line+              -- is unindented, all will get an additional space of+              -- indentation.+              ls' = case all indented ls of+                      True -> map (\ x -> if LL.null x then (LL.cons ' ' $ singleton '.') else x) ls+                      False -> map (LL.cons ' ') $ map (\ x -> if LL.null x then (singleton '.') else x) ls in+          LL.dropWhileEnd isSpace (LL.unlines (l' : ls'))+    where+      indented l = maybe True isSpace (LL.find (const True) l)++-- | This may have bad performance issues (dsf: Whoever wrote this+-- comment should have explained why.)+instance (ControlFunctions a, Pretty (PP a)) => Pretty (Control' a) where+    pPrint = ppControl+instance (ControlFunctions a, Pretty (PP a)) => Pretty (Paragraph' a) where+    pPrint = ppParagraph++instance (ControlFunctions a, Pretty (PP a)) => Pretty (Field' a) where+    pPrint = ppField++ppControl :: (ControlFunctions a, Pretty (PP a)) => Control' a -> Doc+ppControl (Control paragraph) =+    hcat (intersperse (text "\n") (map ppParagraph paragraph))++ppParagraph :: (ControlFunctions a, Pretty (PP a)) => Paragraph' a -> Doc+ppParagraph (Paragraph fields) =+    hcat (map (\ x -> ppField x <> text "\n") fields)++ppField :: (ControlFunctions a, Pretty (PP a)) => Field' a -> Doc+ppField (Field (n,v)) = pPrint (PP n) <> text ":" <> pPrint (PP (protectFieldText v))+ppField (Comment c) = pPrint (PP c)++mergeControls :: [Control' a] -> Control' a+mergeControls controls =+    Control (concatMap unControl controls)++fieldValue :: (ControlFunctions a) => String -> Paragraph' a -> Maybe a+fieldValue fieldName paragraph =+    case lookupP fieldName paragraph of+      Just (Field (_, val)) -> Just $ stripWS val+      _ -> Nothing++removeField :: (Eq a) => a -> Paragraph' a -> Paragraph' a+removeField toRemove (Paragraph fields) =+    Paragraph (filter remove fields)+    where+      remove (Field (name,_)) = name == toRemove+      remove (Comment _) = False++prependFields :: [Field' a] -> Paragraph' a -> Paragraph' a+prependFields newfields (Paragraph fields) = Paragraph (newfields ++ fields)++appendFields :: [Field' a] -> Paragraph' a -> Paragraph' a+appendFields newfields (Paragraph fields) = Paragraph (fields ++ newfields)++renameField :: (Eq a) => a -> a -> Paragraph' a -> Paragraph' a+renameField oldname newname (Paragraph fields) =+    Paragraph (map rename fields)+    where+      rename (Field (name, value)) | name == oldname = Field (newname, value)+      rename field = field++modifyField :: (Eq a) => a -> (a -> a) -> Paragraph' a -> Paragraph' a+modifyField name f (Paragraph fields) =+    Paragraph (map modify fields)+    where+      modify (Field (name', value)) | name' == name = Field (name, f value)+      modify field = field++-- | Move selected fields to the beginning of a paragraph.+raiseFields :: (Eq a) => (a -> Bool) -> Paragraph' a -> Paragraph' a+raiseFields f (Paragraph fields) =+    let (a, b) = partition f' fields in Paragraph (a ++ b)+    where f' (Field (name, _)) = f name+          f' (Comment _) = False++-- | Run a command and parse its output as a control file.+parseControlFromCmd :: ControlFunctions a => String -> IO (Either String (Control' a))+parseControlFromCmd cmd =+    do+      (_, outh, _, handle) <- runInteractiveCommand cmd+      result <- parseControlFromHandle cmd outh+      either (return . Left . show) (finish handle) result+    where+      finish handle control = +          do+            exitCode <- waitForProcess handle+            case exitCode of+              ExitSuccess -> return $ Right control+              ExitFailure n -> return $ Left ("Failure: " ++ cmd ++ " -> " ++ show n)++-- |look up the md5sum file in a paragraph+-- Tries several different variations:+--  MD5Sum:+--  Md5Sum:+--  MD5sum:+md5sumField :: (ControlFunctions a) => Paragraph' a -> Maybe a+md5sumField p =+    case fieldValue "MD5Sum" p of+      m@(Just _) -> m+      Nothing -> +          case fieldValue "Md5Sum" p of+            m@(Just _) -> m+            Nothing -> fieldValue "MD5sum" p

@@ -0,0 +1,180 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+-- | Access to things that Debian policy says should be in a valid+-- control file.  The pure functions will not throw ControlFileError+-- if they are operating on a DebianControl value returned by+-- validateDebianControl.  However, they might if they are created+-- using unsafeDebianControl.+module Debian.Control.Policy+    ( -- * Validated debian control file type+      DebianControl(unDebianControl)+    , validateDebianControl+    , unsafeDebianControl+    , parseDebianControlFromFile+    , parseDebianControl+    , ControlFileError(..)+    -- * Class of things that contain one DebianControl value+    , HasDebianControl(debianControl)+    -- * Pure functions that operate on validated control files+    , debianSourceParagraph+    , debianBinaryParagraphs+    , debianPackageParagraphs+    , debianPackageNames+    , debianSourcePackageName+    , debianBinaryPackageNames+    , debianRelations+    , debianBuildDeps+    , debianBuildDepsIndep+    ) where++import Control.Exception (Exception, throw)+import Control.Monad.Catch (MonadCatch, try)+import Data.List (intercalate)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Data.ListLike (toList)+import Debian.Control.Common (Control'(..), Paragraph'(..), Field'(..), fieldValue, ControlFunctions(parseControlFromFile, parseControl))+import Debian.Control.Text ()+import Debian.Loc (__LOC__)+import Debian.Pretty (prettyShow)+import Debian.Relation (SrcPkgName(..), BinPkgName(..), Relations, parseRelations)+import Debian.Relation.Text ()+import Language.Haskell.TH (Loc(..))+import Prelude hiding (ioError)+-- import qualified Debug.ShowPlease as Please+import Text.Parsec.Error (ParseError)++-- | Opaque (constructor not exported) type to hold a validated Debian+-- Control File+data DebianControl = DebianControl {unDebianControl :: Control' Text}++instance Show DebianControl where+    show c = "(parseDebianControl \"\" " ++ show (prettyShow (unDebianControl c)) ++ ")"++-- | Validate and return a control file in an opaque wrapper.  May+-- throw a ControlFileError.  Currently we only verify that it has a+-- Source field in the first paragraph and one or more subsequent+-- paragraphs each with a Package field, and no syntax errors in the+-- build dependencies (though they may be absent.)+validateDebianControl :: MonadCatch m => Control' Text -> m (Either ControlFileError DebianControl)+validateDebianControl ctl =+    try (do _ <- return $ debianPackageNames (DebianControl ctl)+            _ <- return $ debianBuildDeps (DebianControl ctl)+            _ <- return $ debianBuildDepsIndep (DebianControl ctl)+            return ()) >>=+    return . either Left (\ _ -> Right $ DebianControl ctl)++unsafeDebianControl :: Control' Text -> DebianControl+unsafeDebianControl = DebianControl++parseDebianControl :: MonadCatch m => String -> Text -> m (Either ControlFileError DebianControl)+parseDebianControl sourceName s = either (return . Left . ParseControlError [$__LOC__]) validateDebianControl (parseControl sourceName s)++parseDebianControlFromFile :: FilePath -> IO (Either ControlFileError DebianControl)+parseDebianControlFromFile controlPath =+  try (parseControlFromFile controlPath) >>=+  either (return . Left . IOError [$__LOC__])+         (either (return . Left . ParseControlError [$__LOC__]) validateDebianControl)++-- | Class of things that contain a validated Debian control file.+class HasDebianControl a where+    debianControl :: a -> DebianControl++instance HasDebianControl DebianControl where+    debianControl = id++class HasControl a where+    control :: a -> Control' Text++instance HasControl (Control' Text) where+    control = id++instance HasControl DebianControl where+    control = unDebianControl++-- | Errors that control files might throw, with source file name and+-- line number generated by template haskell.+data ControlFileError+    = NoParagraphs        {locs :: [Loc]}+    | NoBinaryParagraphs  {locs :: [Loc]}+    | MissingField        {locs :: [Loc], field :: String}+    | ParseRelationsError {locs :: [Loc], parseError :: ParseError}+    | ParseControlError   {locs :: [Loc], parseError :: ParseError}+    | IOError             {locs :: [Loc], ioError :: IOError}+    deriving Typeable++instance Show ControlFileError where+    show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs"+    show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs"+    show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field+    show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError+    show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError+    show (IOError {..}) = intercalate ", " (map showLoc locs) ++ ": IOError " ++ show ioError++showLoc :: Loc -> String+showLoc x = show (loc_filename x) ++ "(line " ++ show (fst (loc_start x)) ++ ", column " ++ show (snd (loc_start x)) ++ ")"++-- instance Please.Show ControlFileError where+--     show (IOError e) = "(IOError " ++ Please.show e ++ ")"+--     show (ParseRelationsError e) = "(ParseRelationsError " ++ Please.show e ++ ")"+--     show (ParseControlError e) = "(ParseControlError " ++ Please.show e ++ ")"+--     show x = show x++instance Exception ControlFileError++instance Eq ControlFileError where+    _ == _ = False++debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text])+debianPackageParagraphs ctl =+    case removeCommentParagraphs ctl of+      DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__]+      DebianControl (Control []) -> throw $ NoParagraphs [$__LOC__]+      DebianControl (Control (sourceParagraph : binParagraphs)) -> (sourceParagraph, binParagraphs)++-- | Comment paragraphs are rare, but they happen.+removeCommentParagraphs :: HasDebianControl a => a -> DebianControl+removeCommentParagraphs c =+    DebianControl (Control (filter (not . isCommentParagraph) (unControl (unDebianControl (debianControl c)))))+    where+      isCommentParagraph (Paragraph fields) = all isCommentField fields+      isCommentField (Comment _) = True+      isCommentField _ = False++debianSourceParagraph :: HasDebianControl a => a -> Paragraph' Text+debianSourceParagraph = fst . debianPackageParagraphs++debianBinaryParagraphs :: HasDebianControl a => a -> [Paragraph' Text]+debianBinaryParagraphs = snd . debianPackageParagraphs++debianPackageNames :: HasDebianControl a => a -> (SrcPkgName, [BinPkgName])+debianPackageNames c =+  let (srcParagraph, binParagraphs) = debianPackageParagraphs c in+  (mapFieldValue (SrcPkgName . toList) "Source" srcParagraph, map (mapFieldValue (BinPkgName . toList) "Package") binParagraphs)++debianSourcePackageName :: HasDebianControl a => a -> SrcPkgName+debianSourcePackageName = fst . debianPackageNames++debianBinaryPackageNames :: HasDebianControl a => a -> [BinPkgName]+debianBinaryPackageNames = snd . debianPackageNames++debianBuildDepsIndep :: HasDebianControl a => a -> Maybe Relations+debianBuildDepsIndep ctl = either throw id $ debianRelations "Build-Depends-Indep" (debianControl ctl)++debianBuildDeps :: HasDebianControl a => a -> Maybe Relations+debianBuildDeps ctl = either throw id $ debianRelations "Build-Depends" (debianControl ctl)++-- | Version of fieldValue that may throw a ControlFileError.  We only+-- use this internally on fields that we already validated.+fieldValue' :: ControlFunctions text => String -> Paragraph' text -> text+fieldValue' fieldName paragraph = maybe (throw $ MissingField [$__LOC__] fieldName) id $ fieldValue fieldName paragraph++-- | This could access fields we haven't validated, so+-- it can return an error.  Additionally, the field might+-- be absent, in which case it returns Nothing.+debianRelations :: HasDebianControl a => String -> a -> Either ControlFileError (Maybe Relations)+debianRelations fieldName ctl = maybe (Right Nothing) (either (Left . ParseRelationsError [$__LOC__]) (Right . Just) . parseRelations) $ fieldValue fieldName (debianSourceParagraph ctl)++-- | Apply a function to the text from a named field in a control file paragraph.+mapFieldValue :: (Text -> a) -> String -> Paragraph' Text -> a+mapFieldValue f fieldName paragraph = f $ fieldValue' fieldName paragraph

@@ -0,0 +1,110 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+module Debian.Control.String+    ( -- * Types+      Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , Control+    , Paragraph+    , Field+    , ControlParser+    , ControlFunctions(..)+    -- * Control File Parser+    , pControl+    -- * Helper Functions+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    ) where++import qualified Control.Exception as E+import Data.Char (toLower)+import Data.List (find)+import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, protectFieldText, asString),+                              Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment),+                              mergeControls, fieldValue, removeField, prependFields, appendFields,+                              renameField, modifyField, raiseFields, protectFieldText')+import System.IO (hGetContents)+import Text.ParserCombinators.Parsec (CharParser, parse, parseFromFile, sepEndBy, satisfy, oneOf, string, lookAhead, try, many, many1, (<|>), noneOf, char, eof)++type Field = Field' String+type Control = Control' String+type Paragraph = Paragraph' String++-- * ControlFunctions++instance ControlFunctions String where+    parseControlFromFile filepath = +        parseFromFile pControl filepath +    parseControlFromHandle sourceName handle = +        E.try (hGetContents handle) >>=+        either (\ (e :: E.SomeException) -> error ("parseControlFromHandle String: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName)+    parseControl sourceName c = +        parse pControl sourceName c+    lookupP fieldName (Paragraph paragraph) = +        find (hasFieldName (map toLower fieldName)) paragraph+        where hasFieldName name (Field (fieldName',_)) = name == map toLower fieldName'+              hasFieldName _ _ = False+    stripWS = reverse . strip . reverse . strip+        where strip = dropWhile (flip elem " \t")+    protectFieldText = protectFieldText'+    asString = id++-- * Control File Parser++type ControlParser a = CharParser () a++-- |A parser for debian control file. This parser handles control files+-- that end without a newline as well as ones that have several blank+-- lines at the end. It is very liberal and does not attempt validate+-- the fields in any way. All trailing, leading, and folded whitespace+-- is preserved in the field values. See 'stripWS'.+pControl :: ControlParser Control+pControl =+    do many $ char '\n'+       sepEndBy pParagraph pBlanks >>= return . Control++pParagraph :: ControlParser Paragraph+pParagraph = many1 (pComment <|> pField) >>= return . Paragraph++-- |We are liberal in that we allow *any* field to have folded white+-- space, even though the specific restricts that to a few fields.+pField :: ControlParser Field+pField =+    do c1 <- noneOf "#\n"+       fieldName <-  many1 $ noneOf ":\n"+       char ':'+       fieldValue <- many fcharfws+       (char '\n' >> return ()) <|> eof+       return $ Field (c1 : fieldName, fieldValue)++pComment :: ControlParser Field+pComment =+    do char '#'+       text <- many (satisfy (not . ((==) '\n')))+       char '\n'+       return $ Comment ("#" ++ text ++ "\n")++fcharfws :: ControlParser Char+fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n')++fchar :: ControlParser Char+fchar = satisfy (/='\n')++_fws :: ControlParser String+_fws =+    try $ do char '\n'+             ws <- many1 (char ' ')+             c <- many1 (satisfy (not . ((==) '\n')))+             return $ '\n' : (ws ++ c)++-- |We go with the assumption that 'blank lines' mean lines that+-- consist of entirely of zero or more whitespace characters.+pBlanks :: ControlParser String+pBlanks = many1 (oneOf " \n")

@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}+module Debian.Control.Text+    ( -- * Types+      Control'(..)+    , Paragraph'(..)+    , Field'(..)+    , Control+    , Paragraph+    , Field+    -- , ControlParser+    , ControlFunctions(..)+    -- * Control File Parser+    -- , pControl+    -- * Helper Functions+    , mergeControls+    , fieldValue+    , removeField+    , prependFields+    , appendFields+    , renameField+    , modifyField+    , raiseFields+    , decodeControl+    , decodeParagraph+    , decodeField+    ) where++import qualified Data.ByteString.Char8 as B+import Data.Char (toLower, chr)+import Data.List (find)+import qualified Data.Text as T (Text, pack, unpack, map, strip, reverse)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+--import Data.Text.IO as T (readFile)+import qualified Debian.Control.ByteString as B+--import Text.Parsec.Error (ParseError)+--import Text.Parsec.Text (Parser)+--import Text.Parsec.Prim (runP)+import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString),+                              Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment),+                              mergeControls, fieldValue, removeField, prependFields, appendFields,+                              renameField, modifyField, raiseFields, protectFieldText')++-- | @parseFromFile p filePath@ runs a string parser @p@ on the+-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError'+-- ('Left') or a value of type @a@ ('Right').+--+-- >  main    = do{ result <- parseFromFile numbers "digits.txt"+-- >              ; case result of+-- >                  Left err  -> print err+-- >                  Right xs  -> print (sum xs)+-- >              }+{-+parseFromFile :: Parser a -> String -> IO (Either ParseError a)+parseFromFile p fname+    = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode)+         return (runP p () fname input)+-}++type Field = Field' T.Text+type Control = Control' T.Text+type Paragraph = Paragraph' T.Text++decodeControl :: B.Control -> Control+decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs)++decodeParagraph :: B.Paragraph -> Paragraph+decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s)++decodeField :: Field' B.ByteString -> Field' T.Text+decodeField (B.Field (name, value)) = Field (decode name, decode value)+decodeField (B.Comment s) = Comment (decode s)++decode :: B.ByteString -> T.Text+decode = decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w)++-- * ControlFunctions++instance ControlFunctions T.Text where+    parseControlFromFile filepath =+        -- The ByteString parser is far more efficient than the Text+        -- parser.  By calling decodeControl we tell the compiler to+        -- use it instead.+        parseControlFromFile filepath >>= return . either Left (Right . decodeControl)+    parseControlFromHandle sourceName handle =+        parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl)+    parseControl sourceName c =+        -- Warning: This is very slow, it does a utf8 round trip+        either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 c))+    lookupP fieldName (Paragraph paragraph) =+        find (hasFieldName (map toLower fieldName)) paragraph+        where hasFieldName :: String -> Field' T.Text -> Bool+              hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName'+              hasFieldName _ _ = False+    stripWS = T.reverse . T.strip . T.reverse . T.strip+    protectFieldText = protectFieldText'+    asString = T.unpack++-- * Control File Parser+{-+-- type ControlParser = GenParser T.Text+type ControlParser a = Parsec T.Text () a++-- |A parser for debian control file. This parser handles control files+-- that end without a newline as well as ones that have several blank+-- lines at the end. It is very liberal and does not attempt validate+-- the fields in any way. All trailing, leading, and folded whitespace+-- is preserved in the field values. See 'stripWS'.+pControl :: ControlParser Control+pControl =+    do many $ char '\n'+       sepEndBy pParagraph pBlanks >>= return . Control++pParagraph :: ControlParser Paragraph+pParagraph = many1 (pComment <|> pField) >>= return . Paragraph++-- |We are liberal in that we allow *any* field to have folded white+-- space, even though the specific restricts that to a few fields.+pField :: ControlParser Field+pField =+    do c1 <- noneOf "#\n"+       fieldName <-  many1 $ noneOf ":\n"+       char ':'+       fieldValue <- many fcharfws+       (char '\n' >> return ()) <|> eof+       return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue)++pComment :: ControlParser Field+pComment =+    do char '#'+       text <- many (satisfy (not . ((==) '\n')))+       char '\n'+       return $ Comment (T.pack ("#" <> text <> "\n"))++fcharfws :: ControlParser Char+fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n')++fchar :: ControlParser Char+fchar = satisfy (/='\n')++_fws :: ControlParser T.Text+_fws =+    try $ do char '\n'+             ws <- many1 (char ' ')+             c <- many1 (satisfy (not . ((==) '\n')))+             return $ T.cons '\n' (T.pack ws <> T.pack c)++-- |We go with the assumption that 'blank lines' mean lines that+-- consist of entirely of zero or more whitespace characters.+pBlanks :: ControlParser T.Text+pBlanks =+    do s <- many1 (oneOf " \n")+       return . T.pack $ s+-}

@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Debian.Deb where++import Control.Monad++import Debian.Control.Common+import System.Directory (canonicalizePath)+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)+import System.Unix.Directory (withTemporaryDirectory, withWorkingDirectory)++fields :: (ControlFunctions a) => FilePath -> IO (Control' a)+fields debFP =+    withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir ->+      do debFP <- canonicalizePath debFP+         withWorkingDirectory tmpdir $+           do (res, out, err) <- readProcessWithExitCode "ar" ["x",debFP,"control.tar.gz"] ""+              when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res)+              (res, out, err) <- readProcessWithExitCode "tar" ["xzf", "control.tar.gz", "./control"] ""+              when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ show out ++ "\n" ++ show err ++ "\n" ++ show res)+              c <- parseControlFromFile "control"+              case c of+                Left e -> error (show e)+                (Right c) -> return c -- I don't think we need seq because parsec will force everything from the file

@@ -0,0 +1,31 @@+{-# LANGUAGE PackageImports #-}+-- |Domain independent functions used by the haskell-debian package.+module Debian.Extra.Files+    ( withTemporaryFile+    ) where++import "mtl" Control.Monad.Trans (MonadIO, liftIO)+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (hPutStr, hClose, openBinaryTempFile)++withTemporaryFile :: MonadIO m+                  => (FilePath -> m a)	-- ^ The function we want to pass a FilePath to+                  -> String		-- ^ The text that the file should contain+                  -> m a		-- ^ The function's return value+withTemporaryFile f text =+    do path <- liftIO writeTemporaryFile+       result <- f path+       liftIO $ removeFile path+       return result+    where+      writeTemporaryFile =+          do dir <- getTemporaryDirectory+             (path, h) <- openBinaryTempFile dir "wtf.tmp"+             hPutStr h text+             hClose h+             return path++-- Example: write the path of the temporary file and its contents into /tmp/result:+-- test =+--   withTemporaryFile f "Some text\n"+--   where f path = readFile path >>= return . (("Contents of " ++ path ++ ":\n") ++) >>= writeFile "/tmp/result"

@@ -0,0 +1,291 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+-- |Figure out the dependency relation between debianized source+-- directories.  The code to actually solve these dependency relations+-- for a particular set of binary packages is in Debian.Repo.Dependency.+module Debian.GenBuildDeps+    ( DepInfo(..)+    , sourceName'+    , relations'+    , binaryNames'+    -- * Preparing dependency info+    , buildDependencies+    , RelaxInfo+    , relaxDeps+    -- * Using dependency info+    , BuildableInfo(..)+    , ReadyTarget(..)+    , buildable+    , compareSource+    -- * Obsolete?+    , orderSource+    , genDeps+    , failPackage+    , getSourceOrder+    ) where++import           Control.Applicative ((<$>))+import           Control.Exception (throw)+import		 Control.Monad (filterM)+import		 Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc)+import		 Data.List+import qualified Data.Map as Map+import		 Data.Maybe+import qualified Data.Set as Set+import           Data.Tree as Tree (Tree(Node, rootLabel, subForest))+import		 Debian.Control (parseControlFromFile)+import		 Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep)+import           Debian.Loc (__LOC__)+import		 Debian.Relation+import		 Debian.Relation.Text ()+import		 System.Directory (getDirectoryContents, doesFileExist)++-- | This type describes the build dependencies of a source package.+data DepInfo = DepInfo {+      sourceName :: SrcPkgName		-- ^ source package name+    , relations :: Relations		-- ^ dependency relations+    , binaryNames :: [BinPkgName]	-- ^ binary dependency names (is this a function of relations?)+    } deriving Show++instance Eq DepInfo where+    a == b = (sourceName a == sourceName b) &&+             Set.fromList (map Set.fromList (relations a)) == Set.fromList (map Set.fromList (relations b)) &&+             Set.fromList (binaryNames a) == Set.fromList (binaryNames b)++-- |Return the dependency info for a source package with the given dependency relaxation.+-- |According to debian policy, only the first paragraph in debian\/control can be a source package+-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-sourcecontrolfiles>+buildDependencies :: HasDebianControl control => control -> DepInfo+buildDependencies control = do+  DepInfo { sourceName = debianSourcePackageName control+          , relations = concat [fromMaybe [] (debianBuildDeps control),+                                fromMaybe [] (debianBuildDepsIndep control)]+          , binaryNames = debianBinaryPackageNames control }++-- | source package name+sourceName' :: HasDebianControl control => control -> SrcPkgName+sourceName' control = debianSourcePackageName control++-- | dependency relations+relations' :: HasDebianControl control => control -> Relations+relations' control = concat [fromMaybe [] (debianBuildDeps control),+                            fromMaybe [] (debianBuildDepsIndep control)]++-- | binary dependency names (is this a function of relations?)+binaryNames' :: HasDebianControl control => control -> [BinPkgName]+binaryNames' control = debianBinaryPackageNames control++-- |Specifies build dependencies that should be ignored during the build+-- decision.  If the pair is (BINARY, Nothing) it means the binary package+-- BINARY should always be ignored when deciding whether to build.  If the+-- pair is (BINARY, Just SOURCE) it means that binary package BINARY should+-- be ignored when deiciding whether to build package SOURCE.+newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show++-- | Given a source package name and a binary package name, return+-- False if the binary package should be ignored hwen deciding whether+-- to build the source package.  This is used to prevent build+-- dependency cycles from triggering unnecessary rebuilds.  (This is a+-- replacement for the RelaxInfo type, which we temporarily rename+-- OldRelaxInfo.)+type RelaxInfo = SrcPkgName -> BinPkgName -> Bool++-- |Remove any dependencies that are designated \"relaxed\" by relaxInfo.+relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]+relaxDeps relaxInfo deps =+    map relaxDep deps+    where+      relaxDep :: DepInfo -> DepInfo+      relaxDep info = info {relations = filteredDependencies}+          where+            -- Discard any dependencies not on the filtered package name list.  If+            -- this results in an empty list in an or-dep the entire dependency can+            -- be discarded.+            filteredDependencies :: Relations+            filteredDependencies = filter (/= []) (map (filter keepDep) (relations info))+            keepDep :: Relation -> Bool+            keepDep (Rel name _ _) = not (relaxInfo (sourceName info) name)++data ReadyTarget a+    = ReadyTarget { ready :: a+                  -- ^ Some target whose build dependencies are all satisfied+                  , waiting :: [a]+                  -- ^ The targets that are waiting for the ready target+                  , other :: [a]+                  -- ^ The rest of the targets that need to be built+                  }++data BuildableInfo a+    = BuildableInfo+      { readyTargets :: [ReadyTarget a]+      , allBlocked :: [a] }+    | CycleInfo+      { depPairs :: [(a, a)] }++-- | Given an ordering function representing the dependencies on a+-- list of packages, return a ReadyTarget triple: One ready package,+-- the packages that depend on the ready package directly or+-- indirectly, and all the other packages.+buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a+buildable relax packages =+    -- Find all packages which can't reach any other packages in the+    -- graph of the "has build dependency" relation.+    case partition (\ x -> reachable hasDep x == [x]) verts of+      -- None of the packages are buildable, return information+      -- about how to break this build dependency cycle.+      ([], _) -> CycleInfo {depPairs = map ofEdge $ head $ (allCycles hasDep)}+      -- We have some buildable packages, return them along with+      -- the list of packages each one directly blocks+      (allReady, blocked) ->+          BuildableInfo { readyTargets = map (makeReady blocked allReady) allReady+                        , allBlocked = map ofVertex blocked }+    where+      makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a+      makeReady blocked ready thisReady =+          let otherReady = filter (/= thisReady) ready+              (directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in+          ReadyTarget { ready = ofVertex thisReady+                      , waiting = map ofVertex directlyBlocked+                      , other = map ofVertex (otherReady ++ otherBlocked) }+      --allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x)))+      isDep :: Graph+      isDep = transposeG hasDep+      hasDep :: Graph+      hasDep = buildG (0, length packages - 1) hasDepEdges++      hasDepEdges :: [(Int, Int)]+      hasDepEdges =+          nub (foldr f [] (tails vertPairs))+          where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)]+                f [] es = es+                f (x : xs) es = catMaybes (map (toEdge x) xs) ++ es+                toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge+                toEdge (xv, xa) (yv, ya) =+                    case compareSource xa ya of+                      EQ -> Nothing+                      LT -> Just (yv, xv)+                      GT -> Just (xv, yv)+      ofEdge :: Edge -> (a, a)+      ofEdge (a, b) = (ofVertex a, ofVertex b)+      ofVertex :: Int -> a+      ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages))))+      verts :: [Int]+      verts = map fst vertPairs+      vertPairs :: [(Int, DepInfo)]+      vertPairs = zip [0..] $ map relax packages++-- | Find a cycle in a graph that involves+allCycles :: Graph -> [[Edge]]+allCycles g =+    -- Every cycle is confined to an SCC (strongly connected component).+    -- Every node in an SCC is part of some cycle.+    concatMap sccCycles (scc g)+    where+      -- Find all the cycles in an SCC+      sccCycles :: Tree Vertex -> [[Edge]]+      sccCycles t = mapMaybe addBackEdge (treePaths t)++      addBackEdge :: [Vertex] -> Maybe [Edge]+      addBackEdge path@(root : _) =+          let back = (last path, root) in+          if elem back (edges g) then Just (pathEdges (path ++ [root])) else Nothing++-- | All the paths from root to a leaf+treePaths :: Tree a -> [[a]]+treePaths (Node {rootLabel = r, subForest = []}) = [[r]]+treePaths (Node {rootLabel = r, subForest = ts}) = map (r :) (concatMap treePaths ts)++pathEdges :: [a] -> [(a, a)]+pathEdges (v1 : v2 : vs) = (v1, v2) : pathEdges (v2 : vs)+pathEdges _ = []++-- | Remove any packages which can't be built given that a package has failed.+failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a])+failPackage cmp failed packages =+    let graph = buildGraph cmp packages in+    let root = elemIndex failed packages in+    let victims = maybe [] (map (fromJust . vertex) . reachable graph) root in+    partition (\ x -> not . elem x $ victims) packages+    where+      vertex n = Map.findWithDefault Nothing n vertexMap+      vertexMap = Map.fromList (zip [0..] (map Just packages))++-- | Given a list of packages, sort them according to their apparant+-- build dependencies so that the first element doesn't depend on any+-- of the other packages.+orderSource :: (a -> a -> Ordering) -> [a] -> [a]+orderSource cmp packages =+    map (fromJust . vertex) (topSort graph)+    where+      graph = buildGraph cmp packages+      vertex n = Map.findWithDefault Nothing n vertexMap+      vertexMap = Map.fromList (zip [0..] (map Just packages))++-- | Build a graph with the list of packages as its nodes and the+-- build dependencies as its edges.+buildGraph :: (a -> a -> Ordering) -> [a] -> Graph+buildGraph cmp packages =+    let es = someEdges (zip packages [0..]) in+    buildG (0, length packages - 1) es+    where+      someEdges [] = []+      someEdges (a : etc) = aEdges a etc ++ someEdges etc+      aEdges (ap, an) etc =+          concat (map (\ (bp, bn) ->+                           case cmp ap bp of+                             LT -> [(an, bn)]+                             GT -> [(bn, an)]+                             EQ -> []) etc)++-- |This is a nice start. It ignores circular build depends and takes+-- a pretty simplistic approach to 'or' build depends. However, I+-- think this should work pretty nicely in practice.+compareSource :: DepInfo -> DepInfo -> Ordering+compareSource (DepInfo {relations = depends1, binaryNames = bins1}) (DepInfo {relations = depends2, binaryNames = bins2})+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT+    | otherwise = EQ+    where+      checkPackageNameReq :: Relation -> BinPkgName -> Bool+      checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName++compareSource' :: HasDebianControl control => control -> control -> Ordering+compareSource' control1 control2+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT+    | any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT+    | otherwise = EQ+    where+      bins1 = binaryNames' control1+      bins2 = binaryNames' control2+      depends1 = relations' control1+      depends2 = relations' control2+      checkPackageNameReq :: Relation -> BinPkgName -> Bool+      checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName++-- |Return the dependency info for a list of control files.+genDeps :: [FilePath] -> IO [DebianControl]+genDeps controlFiles = do+  orderSource compareSource' <$> mapM genDep' controlFiles+    where+      -- Parse the control file and extract the build dependencies+      genDep' controlPath = parseControlFromFile controlPath >>=+                            either (\ x -> throw (ParseRelationsError [$__LOC__] x))+                                   (\ x -> validateDebianControl x {- `mapExn` (pushLoc $__LOC__) -} >>= either throw return)++-- pushLoc :: Loc -> ControlFileError -> ControlFileError+-- pushLoc loc e = e {locs = loc : locs e}++-- |One example of how to tie the below functions together. In this+-- case 'fp' is the path to a directory that contains a bunch of+-- checked out source packages. The code will automatically look for+-- debian\/control. It returns a list with the packages in the+-- order they should be built.+getSourceOrder :: FilePath -> IO [SrcPkgName]+getSourceOrder fp =+    findControlFiles fp >>= genDeps >>= return . map sourceName'+    where+      -- Return a list of the files that look like debian\/control.+      findControlFiles :: FilePath -> IO [FilePath]+      findControlFiles root =+          getDirectoryContents root >>=+          mapM (\ x -> return $ root ++ "/" ++ x ++ "/debian/control") >>=+          filterM doesFileExist

@@ -0,0 +1,23 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}+module Debian.Loc+    ( __LOC__+    , mapExn+    ) where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Exception (Exception, throw)+import Control.Monad.Catch (MonadCatch, catch)+import Language.Haskell.TH++__LOC__ :: Q Exp+__LOC__ = location >>= \ x ->+             recConE 'Loc [ (,) <$> (pure 'loc_filename) <*> litE (stringL (loc_filename x))+                          , (,) <$> (pure 'loc_package) <*> litE (stringL (loc_package x))+                          , (,) <$> (pure 'loc_module) <*> litE (stringL (loc_module x))+                          , (,) <$> (pure 'loc_start) <*> [|($(litE (integerL (fromIntegral (fst (loc_start x))))),+                                                             $(litE (integerL (fromIntegral (snd (loc_start x)))))) :: (Int, Int)|]+                          , (,) <$> (pure 'loc_end) <*> [|($(litE (integerL (fromIntegral (fst (loc_end x))))),+                                                           $(litE (integerL (fromIntegral (snd (loc_end x)))))) :: (Int, Int)|] ]++mapExn :: forall e m a. (MonadCatch m, Exception e) => m a -> (e -> e) -> m a+mapExn task f = task `catch` (\ (e :: e) -> throw (f e))

@@ -0,0 +1,46 @@+-- | A constructor we can wrap around values to avoid any built in+-- Pretty instance - for example, instance Pretty [a].+--+--  * display is now prettyShow+--  * display' is now prettyText+--  * ppDisplay is now ppShow+--  * ppDisplay' is now ppText+{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-}+module Debian.Pretty+    ( PP(PP, unPP)+    , prettyShow+    , prettyText+    , ppPrint+    , ppShow+    , ppText+    ) where++import Data.Text (Text, unpack, pack)+import Text.PrettyPrint.HughesPJClass (Doc, Pretty(pPrint), text, empty, prettyShow)++-- | This type is wrapped around values before we pretty print them so+-- we can write our own Pretty instances for common types without+-- polluting the name space of clients of this package with instances+-- they don't want.+newtype PP a = PP {unPP :: a} deriving (Functor)++instance Pretty (PP Text) where+    pPrint = text . unpack . unPP++instance Pretty (PP String) where+    pPrint = text . unPP++instance Pretty (PP a) => Pretty (PP (Maybe a)) where+    pPrint = maybe empty ppPrint . unPP++prettyText :: Pretty a => a -> Text+prettyText = pack . prettyShow++ppPrint :: Pretty (PP a) => a -> Doc+ppPrint = pPrint . PP++ppShow :: Pretty (PP a) => a -> String+ppShow = prettyShow . PP++ppText :: Pretty (PP a) => a -> Text+ppText = pack . prettyShow . PP

@@ -0,0 +1,25 @@+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation+    ( -- * Types+      PkgName(..)+    , SrcPkgName(..)+    , BinPkgName(..)+    , Relations+    , AndRelation+    , OrRelation+    , Relation(..)+    , ArchitectureReq(..)+    , Arch(..)+    , ArchOS(..)+    , ArchCPU(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    ) where++import Debian.Arch (Arch(..), ArchOS(..), ArchCPU(..))+import Debian.Relation.Common (SrcPkgName(..), BinPkgName(..), PkgName(pkgNameFromString))+import Debian.Relation.String

@@ -0,0 +1,30 @@+{-# OPTIONS -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation.ByteString+    ( -- * Types+      AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    ) where ++import qualified Data.ByteString.Char8 as C++-- Local Modules++--import Debian.Relation.Common+import Debian.Relation.String+--import Debian.Version++-- * ParseRelations++-- For now we just wrap the string version+instance ParseRelations C.ByteString where+    parseRelations byteStr = parseRelations (C.unpack byteStr)

@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-}+module Debian.Relation.Common where++-- Standard GHC Modules++import Data.Data (Data)+import Data.List as List (map, intersperse)+import Data.Monoid (mconcat, (<>))+import Data.Function+import Data.Set as Set (Set, toList)+import Data.Typeable (Typeable)+import Debian.Arch (Arch, prettyArch)+import Debian.Pretty (PP(..))+import Prelude hiding (map)+import Text.ParserCombinators.Parsec+import Text.PrettyPrint (Doc, text, empty)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))++-- Local Modules++import Debian.Version++-- Datatype for relations++type Relations = AndRelation+type AndRelation = [OrRelation]+type OrRelation = [Relation]++data Relation = Rel BinPkgName (Maybe VersionReq) (Maybe ArchitectureReq) deriving (Eq, Read, Show)++newtype SrcPkgName = SrcPkgName {unSrcPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable)+newtype BinPkgName = BinPkgName {unBinPkgName :: String} deriving (Read, Show, Eq, Ord, Data, Typeable)++class Pretty (PP a) => PkgName a where+    pkgNameFromString :: String -> a++instance PkgName BinPkgName where+    pkgNameFromString = BinPkgName++instance PkgName SrcPkgName where+    pkgNameFromString = SrcPkgName++class ParseRelations a where+    -- |'parseRelations' parse a debian relation (i.e. the value of a+    -- Depends field). Return a parsec error or a value of type+    -- 'Relations'+    parseRelations :: a -> Either ParseError Relations++-- | This needs to be indented for use in a control file: intercalate "\n     " . lines . show+prettyRelations :: [[Relation]] -> Doc+prettyRelations xss = mconcat . intersperse (text "\n, ") . List.map prettyOrRelation $ xss++prettyOrRelation :: [Relation] -> Doc+prettyOrRelation xs = mconcat . intersperse (text " | ") . List.map prettyRelation $ xs++prettyRelation :: Relation -> Doc+prettyRelation (Rel name ver arch) =+    pPrint (PP name) <> maybe empty prettyVersionReq ver <> maybe empty prettyArchitectureReq arch++instance Ord Relation where+    compare (Rel pkgName1 mVerReq1 _mArch1) (Rel pkgName2 mVerReq2 _mArch2) =+	case compare pkgName1 pkgName2 of+	     LT -> LT+	     GT -> GT+	     EQ -> compare mVerReq1 mVerReq2++data ArchitectureReq+    = ArchOnly (Set Arch)+    | ArchExcept (Set Arch)+    deriving (Eq, Ord, Read, Show)++prettyArchitectureReq :: ArchitectureReq -> Doc+prettyArchitectureReq (ArchOnly arch) = text " [" <> mconcat (List.map prettyArch (toList arch)) <> text "]"+prettyArchitectureReq (ArchExcept arch) = text " [" <> mconcat (List.map ((text "!") <>) (List.map prettyArch (toList arch))) <> text "]"++data VersionReq+    = SLT DebianVersion+    | LTE DebianVersion+    | EEQ  DebianVersion+    | GRE  DebianVersion+    | SGR DebianVersion+      deriving (Eq, Read, Show)++prettyVersionReq :: VersionReq -> Doc+prettyVersionReq (SLT v) = text " (<< " <> prettyDebianVersion v <> text ")"+prettyVersionReq (LTE v) = text " (<= " <> prettyDebianVersion v <> text ")"+prettyVersionReq (EEQ v) = text " (= " <> prettyDebianVersion v <> text ")"+prettyVersionReq (GRE v) = text " (>= " <> prettyDebianVersion v <> text ")"+prettyVersionReq (SGR v) = text " (>> " <> prettyDebianVersion v <> text ")"++-- |The sort order is based on version number first, then on the kind of+-- relation, sorting in the order <<, <= , ==, >= , >>+instance Ord VersionReq where+    compare = compare `on` extr+      where extr (SLT v) = (v,0 :: Int)+            extr (LTE v) = (v,1 :: Int)+            extr (EEQ v) = (v,2 :: Int)+            extr (GRE v) = (v,3 :: Int)+            extr (SGR v) = (v,4 :: Int)++-- |Check if a version number satisfies a version requirement.+checkVersionReq :: Maybe VersionReq -> Maybe DebianVersion -> Bool+checkVersionReq Nothing _ = True+checkVersionReq _ Nothing = False+checkVersionReq (Just (SLT v1)) (Just v2) = v2 < v1+checkVersionReq (Just (LTE v1)) (Just v2) = v2 <= v1+checkVersionReq (Just (EEQ v1)) (Just v2) = v2 == v1+checkVersionReq (Just (GRE v1)) (Just v2) = v2 >= v1+checkVersionReq (Just (SGR v1)) (Just v2) = v2 > v1++instance Pretty (PP BinPkgName) where+    pPrint = text . unBinPkgName . unPP++instance Pretty (PP SrcPkgName) where+    pPrint = text . unSrcPkgName . unPP++-- | Wrap `PP` around type synonyms that might overlap with the+-- `Pretty [a]` instance.+instance Pretty (PP Relations) where+    pPrint = prettyRelations . unPP++instance Pretty (PP OrRelation) where+    pPrint = prettyOrRelation . unPP++instance Pretty (PP Relation) where+    pPrint = prettyRelation . unPP++instance Pretty (PP VersionReq) where+    pPrint = prettyVersionReq . unPP++instance Pretty (PP ArchitectureReq) where+    pPrint = prettyArchitectureReq . unPP

@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-}+{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation.String+    ( -- * Types+      AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    , pRelations+    ) where++-- Standard GHC Modules++import "mtl" Control.Monad.Identity (Identity)+import Data.Set (fromList)+import Text.ParserCombinators.Parsec+import Text.Parsec.Prim (ParsecT)++-- Local Modules++import Debian.Arch (Arch, parseArch)+import Debian.Relation.Common+import Debian.Version++-- * ParseRelations++instance ParseRelations String where+    parseRelations str =+        let str' = scrub str in+        case parse pRelations str' str' of+          Right relations -> Right (filter (/= []) relations)+          x -> x+        where+          scrub = unlines . filter (not . comment) . lines+          comment s = case dropWhile (`elem` " \t") s of+                           ('#' : _) -> True+                           _ -> False++-- * Relation Parser++type RelParser a = CharParser () a++-- "Correct" dependency lists are separated by commas, but sometimes they+-- are omitted and it is possible to parse relations without them.+pRelations :: RelParser Relations+pRelations = do -- rel <- sepBy pOrRelation (char ',')+		rel <- many pOrRelation+                eof+                return rel++pOrRelation :: RelParser OrRelation+pOrRelation = do skipMany (char ',' <|> whiteChar)+                 rel <- sepBy1 pRelation (char '|')+                 skipMany (char ',' <|> whiteChar)+                 return rel++whiteChar :: ParsecT String u Identity Char+whiteChar = oneOf [' ','\t','\n']++pRelation :: RelParser Relation+pRelation =+    do skipMany whiteChar+       pkgName <- many1 (noneOf [' ',',','|','\t','\n','('])+       skipMany whiteChar+       mVerReq <- pMaybeVerReq+       skipMany whiteChar+       mArch <- pMaybeArch+       return $ Rel (BinPkgName pkgName) mVerReq mArch++pMaybeVerReq :: RelParser (Maybe VersionReq)+pMaybeVerReq =+    do char '('+       skipMany whiteChar+       op <- pVerReq+       skipMany whiteChar+       ver <- many1 (noneOf [' ',')','\t','\n'])+       skipMany whiteChar+       char ')'+       return $ Just (op (parseDebianVersion ver))+    <|>+    do return $ Nothing++pVerReq :: ParsecT [Char] u Identity (DebianVersion -> VersionReq)+pVerReq =+    do char '<'+       (do char '<' <|> char ' ' <|> char '\t'+	   return $ SLT+        <|>+        do char '='+	   return $ LTE)+    <|>+    do string "="+       return $ EEQ+    <|>+    do char '>'+       (do char '='+ 	   return $ GRE+        <|>+        do char '>' <|> char ' ' <|> char '\t'+	   return $ SGR)++pMaybeArch :: RelParser (Maybe ArchitectureReq)+pMaybeArch =+    do char '['+       (do archs <- pArchExcept+	   char ']'+           skipMany whiteChar+	   return (Just (ArchExcept (fromList . map parseArchExcept $ archs)))+	<|>+	do archs <- pArchOnly+	   char ']'+           skipMany whiteChar+	   return (Just (ArchOnly (fromList . map parseArch $ archs)))+	)+    <|>+    return Nothing++-- Some packages (e.g. coreutils) have architecture specs like [!i386+-- !hppa], even though this doesn't really make sense: once you have+-- one !, anything else you include must also be (implicitly) a !.+pArchExcept :: RelParser [String]+pArchExcept = sepBy (char '!' >> many1 (noneOf [']',' '])) (skipMany1 whiteChar)++pArchOnly :: RelParser [String]+pArchOnly = sepBy (many1 (noneOf [']',' '])) (skipMany1 whiteChar)++-- | Ignore the ! if it is present, we already know this list has at+-- least one, and the rest are implicit.+parseArchExcept :: String -> Arch+parseArchExcept ('!' : s) = parseArch s+parseArchExcept s = parseArch s

@@ -0,0 +1,30 @@+{-# OPTIONS -fno-warn-orphans #-}+-- |A module for working with debian relationships <http://www.debian.org/doc/debian-policy/ch-relationships.html>+module Debian.Relation.Text+    ( -- * Types+      AndRelation+    , OrRelation+    , Relations+    , Relation(..)+    , ArchitectureReq(..)+    , VersionReq(..)+    -- * Helper Functions+    , checkVersionReq+    -- * Relation Parser+    , RelParser+    , ParseRelations(..)+    ) where ++import qualified Data.Text as T++-- Local Modules++--import Debian.Relation.Common+import Debian.Relation.String+--import Debian.Version++-- * ParseRelations++-- For now we just wrap the string version+instance ParseRelations T.Text where+    parseRelations text = parseRelations (T.unpack text)

@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Debian.Release+    ( ReleaseName(..)+    , parseReleaseName+    , releaseName'+    , Section(..)+    , SubSection(..)+    , sectionName+    , sectionName'+    , sectionNameOfSubSection+    , parseSection+    , parseSection'+    ) where++import Data.Data (Data)+import Data.Typeable (Typeable)+import Network.URI (unEscapeString, escapeURIString, isAllowedInURI)++-- |A distribution (aka release) name.  This type is expected to refer+-- to a subdirectory of the dists directory which is at the top level+-- of a repository.+data ReleaseName = ReleaseName { relName :: String } deriving (Eq, Ord, Read, Show, Data, Typeable)++parseReleaseName :: String -> ReleaseName+parseReleaseName name = ReleaseName {relName = unEscapeString name}++releaseName' :: ReleaseName -> String+releaseName' (ReleaseName {relName = s}) = escapeURIString isAllowedInURI s++-- |A section of a repository such as main, contrib, non-free,+-- restricted.  The indexes for a section are located below the+-- distribution directory.+newtype Section = Section String deriving (Read, Show, Eq, Ord)++-- |A package's subsection is only evident in its control information,+-- packages from different subsections all reside in the same index.+data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, Show, Eq, Ord)++sectionName :: SubSection -> String+sectionName (SubSection (Section "main") y) = y+sectionName (SubSection x y) = sectionName' x ++ "/" ++ y++sectionName' :: Section -> String+sectionName' (Section s) = escapeURIString isAllowedInURI s++sectionNameOfSubSection :: SubSection -> String+sectionNameOfSubSection = sectionName' . section++-- |Parse the value that appears in the @Section@ field of a .changes file.+-- (Does this need to be unesacped?)+parseSection :: String -> SubSection+parseSection s =+    case span (/= '/') s of+      (x, "") -> SubSection (Section "main") x+      ("main", y) -> SubSection (Section "main") y+      (x, y) -> SubSection (Section x) (tail y)++parseSection' :: String -> Section+parseSection' name =+    Section (unEscapeString name)

@@ -0,0 +1,87 @@+module Debian.Report where++import Data.Maybe+import qualified Data.Map as M+import Data.Text as Text (Text, unpack)+import Debian.Apt.Index (Fetcher, Compression(..), update, controlFromIndex')+import Debian.Control.Text+import Debian.Sources+import Debian.Version+import Text.XML.HaXml (CFilter, mkElem, cdata)+import Text.XML.HaXml.Posn+import Text.PrettyPrint (render)++-- * General Package Map Builders++-- |create a map of (package name, extracted field) from a list of index files+--+-- NOTE: we could merge all the files into a single control and then+-- run packageMap over that. We currently do it one control file at a+-- time to avoid having all the control files loaded in memory at+-- once. However, I am not sure that property is actually occuring+-- anyway. So, this should be revisited.+makePackageMap :: (Paragraph -> a) -> (a -> a -> a) -> [(FilePath, Compression)] -> IO (M.Map Text a)+makePackageMap _ _ [] = return M.empty+makePackageMap extractValue resolveConflict ((path, compression):is) =+    do r <- controlFromIndex' compression path+       case r of+         (Left e) -> error (show e)+         (Right c) ->+             do let pm = packageMap extractValue resolveConflict c+                pms <- makePackageMap extractValue resolveConflict is+                return $ M.unionWith resolveConflict pm pms++-- |create a map of (package name, max version) from a single control file+packageMap :: (Paragraph -> a) -> (a -> a -> a) -> Control' Text -> M.Map Text a+packageMap extractValue resolveConflict control =+    M.fromListWith resolveConflict (map packageTuple (unControl control))+    where+      packageTuple paragraph = (fromJust $ fieldValue "Package" paragraph, extractValue paragraph)++-- |extract the version number from a control paragraph+extractVersion :: Paragraph -> Maybe DebianVersion+extractVersion paragraph = fmap (parseDebianVersion . unpack)  $ fieldValue "Version" paragraph++-- * Trump Report++-- |compare two sources.list and find all the packages in the second that trump packages in the first+-- see also: |trumpedMap|+trumped :: Fetcher -- ^ function for downloading package indexes+        -> FilePath -- ^ cache directory to store index files in (must already exist)+        -> String -- ^ binary architecture +        -> [DebSource] -- ^ sources.list a+        -> [DebSource] -- ^ sources.list b+        -> IO (M.Map Text (DebianVersion, DebianVersion)) -- ^ a map of trumped package names to (version a, version b)+trumped fetcher cacheDir arch sourcesA sourcesB =+    do indexesA <- update fetcher cacheDir arch (filter isDebSrc sourcesA)+       pmA <- makePackageMap (fromJust . extractVersion) max (map fromJust indexesA)+       indexesB <- update fetcher cacheDir arch (filter isDebSrc sourcesB)+       pmB <- makePackageMap (fromJust . extractVersion) max (map fromJust indexesB)+       return (trumpedMap pmA pmB)+    where+      isDebSrc ds = sourceType ds == DebSrc++-- |calculate all the trumped packages+trumpedMap :: M.Map Text DebianVersion -- ^ package map a+           -> M.Map Text DebianVersion -- ^ package map b+           -> M.Map Text (DebianVersion, DebianVersion) -- ^ trumped packages (version a, version b)+trumpedMap pmA pmB =+    M.foldWithKey (checkTrumped pmB) M.empty pmA+    where+      checkTrumped pm package aVersion trumpedPM =+          case M.lookup package pm of+            (Just bVersion)+              | bVersion > aVersion -> M.insert package (aVersion, bVersion) trumpedPM+            _ -> trumpedPM++-- |create <trumped /> XML element and children from a trumped Map+trumpedXML :: M.Map Text (DebianVersion, DebianVersion) -> CFilter Posn+trumpedXML trumpedMap' =+    mkElem "trumped" (map mkTrumpedPackage (M.toAscList trumpedMap' ))+    where+      mkTrumpedPackage (package, (oldVersion, newVersion)) =+          mkElem "trumpedPackage"+                     [ mkElem "package" [ cdata (unpack package) ]+                     , mkElem "oldVersion" [ cdata (render . prettyDebianVersion $ oldVersion) ]+                     , mkElem "newVersion" [ cdata (render . prettyDebianVersion $ newVersion) ]+                     ]

@@ -0,0 +1,171 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module Debian.Sources where++import Data.List (intercalate)+import Data.Monoid ((<>))+import Debian.Pretty (PP(..))+import Debian.Release+import Network.URI (URI, uriToString, parseURI, unEscapeString, escapeURIString, isAllowedInURI)+import Text.PrettyPrint (text, hcat)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))++data SourceType+    = Deb | DebSrc+    deriving (Eq, Ord, Show)++data DebSource+    = DebSource+    { sourceType :: SourceType+    , sourceUri :: URI+    , sourceDist :: Either String (ReleaseName, [Section])+    } deriving (Eq, Ord, Show)++instance Pretty SourceType where+    pPrint Deb = text "deb"+    pPrint DebSrc = text "deb-src"++instance Pretty DebSource where+    pPrint (DebSource thetype theuri thedist) =+        pPrint thetype <>+        text (" " <> uriToString id theuri " " <>+              case thedist of+                Left exactPath -> escape exactPath+                Right (dist, sections) -> releaseName' dist <> " " <> intercalate " " (map sectionName' sections))+            where escape = escapeURIString isAllowedInURI++instance Pretty (PP [DebSource]) where+    pPrint = hcat . map (\ x -> pPrint x <> text "\n") . unPP++-- |This is a name given to a combination of parts of one or more+-- releases that can be specified by a sources.list file.+type SliceName = ReleaseName+-- data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord, Show)++{-++deb uri distribution [component1] [componenent2] [...]++The URI for the deb type must specify the base of the Debian+distribution, from which APT will find the information it needs.++distribution can specify an exact path, in which case the components+must be omitted and distribution must end with a slash (/).++If distribution does not specify an exact path, at least one component+must be present.++Distribution may also contain a variable, $(ARCH), which expands to+the Debian architecture (i386, m68k, powerpc, ...)  used on the+system.++The rest of the line can be marked as a comment by using a #.++Additional Notes:++ + Lines can begin with leading white space.++ + If the dist ends with slash (/), then it must be an absolute path+   and it is an error to specify components after it.++-}++-- |quoteWords - similar to words, but with special handling of+-- double-quotes and brackets.+--+-- The handling double quotes and [] is supposed to match:+-- apt-0.6.44.2\/apt-pkg\/contrib\/strutl.cc:ParseQuoteWord()+--+-- The behaviour can be defined as:+--+--  Break the string into space seperated words ignoring spaces that+--  appear between \"\" or []. Strip trailing and leading white space+--  around words. Strip out double quotes, but leave the square+--  brackets intact.+quoteWords :: String -> [String]+quoteWords [] = []+quoteWords s = quoteWords' (dropWhile (==' ') s)+    where+      quoteWords' :: String -> [String]+      quoteWords' [] = []+      quoteWords' str =+          case break (flip elem " [\"") str of+            ([],[]) -> []+            (w, []) -> [w]+            (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest))+            (w, ('"':rest)) ->+                case break (== '"') rest of+                  (w',('"':rest)) ->+                      case quoteWords' rest of+                        [] ->  [w ++ w']+                        (w'':ws) -> ((w ++ w' ++ w''): ws)+                  (_w',[]) -> error ("quoteWords: missing \" in the string: "  ++ s)+                  _ -> error ("the impossible happened in SourcesList.quoteWords")+            (w, ('[':rest)) ->+                case break (== ']') rest of+                  (w',(']':rest)) ->+                      case quoteWords' rest of+                        []       -> [w ++ "[" ++ w' ++ "]"]+                        (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws)+                  (_w',[]) -> error ("quoteWords: missing ] in the string: "  ++ s)+                  _ -> error ("the impossible happened in SourcesList.quoteWords")+            _ -> error ("the impossible happened in SourcesList.quoteWords")++stripLine :: String -> String+stripLine = takeWhile (/= '#') . dropWhile (== ' ')++sourceLines :: String -> [String]+sourceLines = filter (not . null) . map stripLine . lines++-- |parseSourceLine -- parses a source line+-- the argument must be a non-empty, valid source line with comments stripped+-- see: 'sourceLines'+parseSourceLine :: String -> DebSource+parseSourceLine str =+    case quoteWords str of+      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->+          let sections = map parseSection' sectionStrs+              theType = case unEscapeString theTypeStr of+                          "deb" -> Deb+                          "deb-src" -> DebSrc+                          o -> error ("parseSourceLine: invalid type " ++ o ++ " in line:\n" ++ str)+              theUri = case parseURI theUriStr of+                         Nothing -> error ("parseSourceLine: invalid uri " ++ theUriStr ++ " in the line:\n" ++ str)+                         Just u -> u+              theDist = unEscapeString theDistStr+          in+            case last theDist of+              '/' -> if null sections+                      then DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Left theDist }+                      else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str)+              _ -> if null sections+                    then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str)+                    else DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) }+      _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str)++parseSourceLine' :: String -> Maybe DebSource+parseSourceLine' str =+    case quoteWords str of+      (theTypeStr : theUriStr : theDistStr : sectionStrs) ->+          let sections = map parseSection' sectionStrs+              theType = case unEscapeString theTypeStr of+                          "deb" -> Just Deb+                          "deb-src" -> Just DebSrc+                          _ -> Nothing+              theUri = case parseURI theUriStr of+                         Nothing -> Nothing+                         Just u -> Just u+              theDist = unEscapeString theDistStr+          in+            case (last theDist, theType, theUri) of+              ('/', Just typ, Just uri) -> if null sections+                      then Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Left theDist }+                      else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str)+              (_, Just typ, Just uri) -> if null sections+                    then Nothing+                    else Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) }+              _ -> Nothing+      _ -> Nothing++parseSourcesList :: String -> [DebSource]+parseSourcesList = map parseSourceLine . sourceLines

@@ -0,0 +1,24 @@+module Debian.Time where++import Data.Time+import Data.Time.Clock.POSIX+import System.Locale (defaultTimeLocale)+import System.Posix.Types++-- * Time Helper Functions++rfc822DateFormat :: String+rfc822DateFormat = "%a, %d %b %Y %T %z"++epochTimeToUTCTime :: EpochTime -> UTCTime+epochTimeToUTCTime = posixSecondsToUTCTime . fromIntegral . fromEnum++formatTimeRFC822 :: (FormatTime t) => t -> String+formatTimeRFC822 = formatTime defaultTimeLocale rfc822DateFormat++parseTimeRFC822 :: (ParseTime t) => String -> Maybe t+parseTimeRFC822 = parseTime defaultTimeLocale rfc822DateFormat++getCurrentLocalRFC822Time :: IO String+getCurrentLocalRFC822Time = getCurrentTime >>= utcToLocalZonedTime >>= return . formatTime defaultTimeLocale rfc822DateFormat+

@@ -0,0 +1,90 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS -fno-warn-orphans #-}+module Debian.URI+    ( module Network.URI+    , URI'+    , toURI'+    , fromURI'+    , readURI'+    , uriToString'+    , fileFromURI+    , fileFromURIStrict+    , dirFromURI+    ) where++import Control.Exception (SomeException, try)+import Data.ByteString.Lazy.UTF8 as L+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe (catMaybes, fromJust)+import Network.URI (URI(..), URIAuth(..), parseURI, uriToString)+import System.Directory (getDirectoryContents)+-- import System.Process.ByteString (readProcessWithExitCode)+import System.Process.ByteString.Lazy (readProcessWithExitCode)+import Text.Regex (mkRegex, matchRegex)++-- | A wrapper around a String containing a known parsable URI.  Not+-- absolutely safe, because you could say read "URI' \"bogus string\""+-- :: URI'.  But enough to save me from myself.+newtype URI' = URI' String deriving (Read, Show, Eq, Ord)++readURI' :: String -> Maybe URI'+readURI' s = maybe Nothing (const (Just (URI' s))) (parseURI s)++fromURI' :: URI' -> URI+fromURI' (URI' s) = fromJust (parseURI s)++-- | Using the bogus Show instance of URI here.  If it ever gets fixed+-- this will stop working.  Worth noting that show will obscure any+-- password info embedded in the URI, so that's nice.+toURI' :: URI -> URI'+toURI' = URI' . show++uriToString' :: URI -> String+uriToString' uri = uriToString id uri ""++fileFromURI :: URI -> IO (Either SomeException L.ByteString)+fileFromURI uri = fileFromURIStrict uri++fileFromURIStrict :: URI -> IO (Either SomeException L.ByteString)+fileFromURIStrict uri = try $+    case (uriScheme uri, uriAuthority uri) of+      ("file:", Nothing) -> L.readFile (uriPath uri)+      -- ("ssh:", Just auth) -> cmdOutputStrict ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri))+      ("ssh:", Just auth) -> do+          let cmd = "ssh"+              args = [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "cat", uriPath uri]+          (_code, out, _err) <- readProcessWithExitCode cmd args L.empty+          return out+      _ -> do+          let cmd = "curl"+              args = ["-s", "-g", uriToString' uri]+          (_code, out, _err) <- readProcessWithExitCode cmd args L.empty+          return out++-- | Parse the text returned when a directory is listed by a web+-- server.  This is currently only known to work with Apache.+-- NOTE: there is a second copy of this function in+-- Extra:Extra.Net. Please update both locations if you make changes.+webServerDirectoryContents :: L.ByteString -> [String]+webServerDirectoryContents text =+    catMaybes . map (second . matchRegex re) . Prelude.lines . L.toString $ text+    where+      re = mkRegex "( <A HREF|<a href)=\"([^/][^\"]*)/\""+      second (Just [_, b]) = Just b+      second _ = Nothing+++dirFromURI :: URI -> IO (Either SomeException [String])+dirFromURI uri = try $+    case (uriScheme uri, uriAuthority uri) of+      ("file:", Nothing) -> getDirectoryContents (uriPath uri)+      ("ssh:", Just auth) ->+          do let cmd = "ssh"+                 args = [uriUserInfo auth ++ uriRegName auth ++ uriPort auth, "ls", "-1", uriPath uri]+             (_code, out, _err) <- readProcessWithExitCode cmd args L.empty+             return . Prelude.lines . L.toString $ out+      _ ->+          do let cmd = "curl"+                 args = ["-s", "-g", uriToString' uri]+             (_code, out, _err) <- readProcessWithExitCode cmd args L.empty+             return . webServerDirectoryContents $ out

@@ -0,0 +1,26 @@+-- | There are old index files that have funky characters like 'ø'+-- that are not properly UTF8 encoded.  As far as I can tell, these+-- files are otherwise plain ascii, so just naivelyinsert the+-- character into the output stream.+module Debian.UTF8+    ( decode+    , readFile+    ) where++import Control.Applicative ((<$>))+import qualified Data.ByteString.Char8 as B (concat)+import qualified Data.ByteString.Lazy.Char8 as L (ByteString, readFile, toChunks)+import Data.Char (chr)+import Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Word (Word8)+import Prelude hiding (readFile)++decode :: L.ByteString -> T.Text+decode b = decodeUtf8With e (B.concat (L.toChunks b))+    where+      e :: String -> Maybe Word8 -> Maybe Char+      e _description w = fmap (chr . fromIntegral) w++readFile :: FilePath -> IO T.Text+readFile path = decode <$> L.readFile path

@@ -0,0 +1,256 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module Debian.Util.FakeChanges (fakeChanges) where++--import Control.Arrow+import Control.Exception+import Control.Monad hiding (mapM)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Data (Data, Typeable)+import qualified Data.Digest.Pure.MD5 as MD5+import Data.Foldable (concat, all, foldr)+import Data.List as List (intercalate, nub, partition, isSuffixOf)+import Data.Maybe+import Debian.Pretty (prettyShow)+import Data.Traversable+import Debian.Control+import qualified Debian.Deb as Deb+import Debian.Time+import Network.BSD (getHostName)+import Prelude hiding (concat, foldr, all, mapM, sum)+import System.Environment+import System.FilePath+import System.Posix.Files+import Text.Regex.TDFA++data Error+    = NoDebs+    | TooManyDscs [FilePath]+    | TooManyTars [FilePath]+    | TooManyDiffs [FilePath]+    | UnknownFiles [FilePath]+    | MalformedDebFilename [FilePath]+    | VersionMismatch [Maybe String]+    deriving (Read, Show, Eq, Typeable, Data)++data Files +    = Files { dsc :: Maybe (FilePath, Paragraph) +            , debs :: [(FilePath, Paragraph)]+            , tar :: Maybe FilePath+            , diff :: Maybe FilePath+            }++fakeChanges :: [FilePath] -> IO (FilePath, String)+fakeChanges fps =+    do files <- loadFiles fps+       let version    	= getVersion files+           source       = getSource files+           maintainer   = getMaintainer files+           arches       = getArches files+           binArch      = getBinArch files+           dist	        = "unstable"+           urgency      = "low"+           (invalid, binaries) = unzipEithers $ map (debNameSplit . fst) (debs files)+       when (not . null $ invalid) (error $ "Some .deb names are invalid: " ++ show invalid)+       uploader <- getUploader+       date <- getCurrentLocalRFC822Time+       fileLines <- mapM mkFileLine fps+       let changes = Control $ return . Paragraph $ map Field+               [ ("Format"," 1.7")+               , ("Date", ' ' : date)+               , ("Source", ' ' : source)+               , ("Binary", ' ' : (intercalate " " $ map (\(n,_,_) -> n) binaries))+               , ("Architecture", ' ' : intercalate " " arches)+               , ("Version", ' ' : version)+               , ("Distribution", ' ' : dist)+               , ("Urgency", ' ' : urgency)+               , ("Maintainer", ' ' : maintainer)+               , ("Changed-By", ' ' : uploader)+               , ("Description", "\n Simulated description")+               , ("Changes", "\n" ++ unlines (map (' ':) [ source ++ " (" ++ version ++") " ++ dist ++ "; urgency=" ++ urgency+                                                         , "."+                                                         , "  * Simulated changes"+                                                         ]+                                             ))+               , ("Files", "\n" ++ unlines fileLines)+               ]+       return $ (concat [ source, "_", version, "_", binArch, ".changes"], prettyShow changes)+--       let (invalid, binaries) = unzipEithers $ map debNameSplit debs+{-+       when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid])+       version <- getVersion dsc debs+       putStrLn version+       source <- getSource dsc debs+       putStrLn source+-}+-- TODO: seems like this could be more aggressive about ensure the+-- versions make sense. Except with packages like libc, the versions+-- don't make sense. Maybe we want a flag that disables version check+-- ?+getVersion :: Files -> String+getVersion files+    | isNothing (dsc files) =+        let versions = map (fieldValue "Version" . snd) (debs files)+        in+          if (all isJust versions) && (length (nub versions) == 1)+          then fromJust (head versions)+          else error (show [VersionMismatch (nub versions)])+    | otherwise =+        case fieldValue "Version" (snd . fromJust $ dsc files) of+          (Just v) -> v+          Nothing  -> error $ "show (dsc files)" ++ " does not have a Version field :("+++getSource :: Files -> String+getSource files =+    let dscSource =+            case (dsc files) of+              Nothing -> []+              (Just (fp, p)) ->+                  case fieldValue "Source" p of+                    (Just v) -> [v]+                    Nothing -> error $ fp ++ " does not have a Source field :("+        debSources = map debSource (debs files)+        srcs = nub (dscSource ++ debSources)+    in+      if (singleton srcs)+         then (head srcs)+         else error $ "Could not determine source."+    where+      debSource (deb,p) =+          case (fieldValue "Source" p) of+            (Just v) -> v+            Nothing -> +                case fieldValue "Package" p of+                  (Just v) -> v +                  Nothing -> error $ "Could not find Source or Package field in " ++ deb++++getMaintainer :: Files -> String+getMaintainer files+    | isJust (dsc files) =+        let (fp, p) = fromJust (dsc files)+        in+          case fieldValue "Maintainer" p of+            Nothing -> error $ fp ++ " is missing the Maintainer field."+            (Just v) -> v+    | otherwise =+        let maintainers = catMaybes $ map (fieldValue "Maintainer" . snd) (debs files)+            maintainer = nub maintainers+        in+          if singleton maintainer+             then head maintainer+             else error $ "Could not uniquely determine the maintainer: " ++ show maintainer++getArches :: Files -> [String]+getArches files =+    let debArchs = map (fieldValue "Architecture" . snd) (debs files)+        tarArch  = fmap (const "source") (tar files)+        diffArch = fmap (const "source") (diff files)+    in+      nub $ catMaybes (tarArch : diffArch : debArchs)+++getBinArch :: Files -> String+getBinArch files =+    let binArch = nub $ mapMaybe (fieldValue "Architecture" . snd) (debs files)+    in+      if singleton binArch+         then head binArch+         else case (filter (/= "all") binArch) of+                [b] -> b+                _ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch++mkFileLine :: FilePath -> IO String+mkFileLine fp+    | ".deb" `isSuffixOf` fp =+        do sum <- L.readFile fp >>= return . show . MD5.md5+           size <- liftM fileSize $ getFileStatus fp +           (Control (p:_)) <- Deb.fields fp+           return $ concat [ " ", sum, " ", show size, " ", fromMaybe "unknown" (fieldValue "Section" p), " "+                           , fromMaybe "optional" (fieldValue "Priority" p), " ", (takeBaseName fp)+                           ]+    | otherwise =+        do sum <- L.readFile fp >>= return . show . MD5.md5+           size <- liftM fileSize $ getFileStatus fp+           return $ concat [ " ", sum, " ", show size, " ", "unknown", " "+                           , "optional"," ", (takeBaseName fp)+                           ]+       +-- more implementations can be found at:+-- http://www.google.com/codesearch?hl=en&lr=&q=%22%5BEither+a+b%5D+-%3E+%28%5Ba%5D%2C%5Bb%5D%29%22&btnG=Search+unzipEithers :: [Either a b] -> ([a],[b])+unzipEithers = foldr unzipEither ([],[])+    where+      unzipEither (Left l) ~(ls, rs) = (l:ls, rs)+      unzipEither (Right r) ~(ls, rs) = (ls, r:rs)++-- move to different library+debNameSplit :: String -> Either FilePath (String, String, String)+debNameSplit fp =+    case (takeFileName fp) =~ "^(.*)_(.*)_(.*).deb$" of+      [[_, name, version, arch]] -> Right (name, version, arch)+      _ -> Left fp+    ++loadFiles :: [FilePath] -> IO Files+loadFiles files =+       let (dscs', files'') = partition (isSuffixOf ".dsc") files'+           (debs', files') = partition (isSuffixOf ".deb") files+           (tars', files''') = partition (isSuffixOf ".tar.gz") files''+           (diffs', rest) = partition (isSuffixOf ".diff.gz") files'''+           errors = concat [ if (length debs'  < 1) then [NoDebs] else []+                           , if (length dscs'  > 1) then [TooManyDscs dscs']   else []+                           , if (length tars'  > 1) then [TooManyTars tars']   else []+                           , if (length diffs' > 1) then [TooManyDiffs diffs'] else []+                           , if (length rest  > 0) then [UnknownFiles rest]  else []+                           ]+       in+         do when (not . null $ errors) (error $ show errors)+            dsc' <- mapM loadDsc (listToMaybe dscs')+            debs'' <- mapM loadDeb debs'+            return $ Files { dsc = dsc', debs = debs'', tar = listToMaybe tars', diff = listToMaybe diffs' }+         -- if (not . null $ errors) then throwDyn errors else return (debs, listToMaybe dscs, listToMaybe tars, listToMaybe diffs)+    where+      loadDsc :: FilePath -> IO (FilePath, Paragraph)+      loadDsc dsc' = +          do res <- parseControlFromFile dsc'+             case  res of+               (Left e) -> error $ "Error parsing " ++ dsc' ++ "\n" ++ show e+               (Right (Control [p])) -> return (dsc', p)+               (Right c) -> error $ dsc' ++ " did not have exactly one paragraph: " ++ prettyShow c+      loadDeb :: FilePath -> IO (FilePath, Paragraph)+      loadDeb deb =+          do res <- Deb.fields deb+             case res of+               (Control [p]) -> return (deb, p)+               _ -> error $ deb ++ " did not have exactly one paragraph: " ++ prettyShow res+++getUploader :: IO String+getUploader =+    do debFullName <- +           do dfn <- try (getEnv "DEBFULLNAME")+              case dfn of+                (Right n) -> return n+                (Left (_ :: SomeException)) ->+                    do dfn' <-try (getEnv "USER")+                       case dfn' of+                         (Right n) -> return n+                         (Left (_ :: SomeException)) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set."+       emailAddr <-+           do eml <- try (getEnv "DEBEMAIL")+              case eml of +                (Right e) -> return e+                (Left (_ :: SomeException)) ->+                    do eml' <- try (getEnv "EMAIL")+                       case eml' of+                         (Right e) -> return e+                         (Left (_ :: SomeException)) -> getHostName -- FIXME: this is not a FQDN+       return $ debFullName ++ " <" ++ emailAddr ++ ">"++-- * Utils++singleton :: [a] -> Bool+singleton [_] = True+singleton _ = False

@@ -0,0 +1,15 @@+-- |A module for parsing, comparing, and (eventually) modifying debian version+-- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>+module Debian.Version +    (DebianVersion -- |Exported abstract because the internal representation is likely to change +    , prettyDebianVersion+    , parseDebianVersion+    , epoch+    , version+    , revision+    , buildDebianVersion+    , evr+    ) where ++import Debian.Version.Common+import Debian.Version.String ()

@@ -0,0 +1,18 @@+{-# OPTIONS -fno-warn-orphans #-}+module Debian.Version.ByteString+    ( ParseDebianVersion(..)+    ) where++import Text.ParserCombinators.Parsec++import qualified Data.ByteString.Char8 as C++import Debian.Version.Common+import Debian.Version.Internal+    +instance ParseDebianVersion C.ByteString where+    parseDebianVersion byteStr =+        let str = C.unpack byteStr in+        case parse parseDV str str of+          Left e -> error (show e)+          Right dv -> DebianVersion str dv

@@ -0,0 +1,181 @@+-- |A module for parsing, comparing, and (eventually) modifying debian version+-- numbers. <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Version>+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS -fno-warn-orphans -fno-warn-unused-do-bind #-}+module Debian.Version.Common+    ( DebianVersion -- |Exported abstract because the internal representation is likely to change +    , prettyDebianVersion+    , ParseDebianVersion(..)+    , evr		-- DebianVersion -> (Maybe Int, String, Maybe String)+    , epoch+    , version+    , revision+    , buildDebianVersion+    , parseDV+    ) where++import Data.Char (ord, isDigit, isAlpha)+import Debian.Pretty (PP(..))+import Debian.Version.Internal+import Text.ParserCombinators.Parsec+import Text.Regex+import Text.PrettyPrint (Doc, render)+import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text)++prettyDebianVersion :: DebianVersion -> Doc+prettyDebianVersion (DebianVersion s _) = text s++instance Pretty (PP DebianVersion) where+    pPrint = prettyDebianVersion . unPP++instance Eq DebianVersion where+    (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2++instance Ord DebianVersion where+    compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2++instance Show DebianVersion where+    show v = "(Debian.Version.parseDebianVersion (" ++ show (render (prettyDebianVersion v)) ++ " :: String))"++-- make ~ less than everything, and everything else higher that letters+order :: Char -> Int+order c+    | isDigit c = 0+    | isAlpha c = ord c+    | c == '~' = -1+    | otherwise = (ord c) + 256++-- |We have to do this wackiness because ~ is less than the empty string+compareNonNumeric :: [Char] -> [Char] -> Ordering+compareNonNumeric "" "" = EQ+compareNonNumeric "" ('~':_cs) = GT+compareNonNumeric ('~':_cs) "" = LT+compareNonNumeric "" _ = LT+compareNonNumeric _ "" = GT+compareNonNumeric (c1:cs1) (c2:cs2) =+    if (order c1) == (order c2)+       then compareNonNumeric cs1 cs2+       else compare (order c1) (order c2)++instance Eq NonNumeric where+    (NonNumeric s1 n1) == (NonNumeric s2 n2) =+        case compareNonNumeric s1 s2 of+          EQ -> n1 == n2+          _o -> False++instance Ord NonNumeric where+    compare (NonNumeric s1 n1) (NonNumeric s2 n2) =+        case compareNonNumeric s1 s2 of+          EQ -> compare n1 n2+          o -> o++instance Eq Numeric where+    (Numeric n1 mnn1) == (Numeric n2 mnn2) =+        case compare n1 n2 of+          EQ -> case compareMaybeNonNumeric mnn1 mnn2 of+                  EQ -> True+                  _ -> False+          _ -> False++compareMaybeNonNumeric :: Maybe NonNumeric -> Maybe NonNumeric -> Ordering+compareMaybeNonNumeric mnn1 mnn2 =+    case (mnn1, mnn2) of+      (Nothing, Nothing) -> EQ+      (Just (NonNumeric nn _), Nothing) -> compareNonNumeric nn ""+      (Nothing, Just (NonNumeric nn _)) -> compareNonNumeric "" nn+      (Just nn1, Just nn2) -> compare nn1 nn2++instance Ord Numeric where+    compare (Numeric n1 mnn1) (Numeric n2 mnn2) =+        case compare n1 n2 of+          EQ -> compareMaybeNonNumeric mnn1 mnn2+          o -> o++-- * Parser++class ParseDebianVersion a where+    parseDebianVersion :: a-> DebianVersion+-- |Convert a string to a debian version number. May throw an+-- exception if the string is unparsable -- but I am not sure if that+-- can currently happen. Are there any invalid version strings?+-- Perhaps ones with underscore, or something?++{-+showNN :: NonNumeric -> String+showNN (NonNumeric s n) = s ++ showN n++showN :: Found Numeric -> String+showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn+showN (Simulated _) = "" +-}++parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric)+parseDV =+    do skipMany $ oneOf " \t"+       e <- parseEpoch +       upstreamVersion <- parseNonNumeric True True+       debianRevision <- option (Simulated (NonNumeric "" (Simulated (Numeric 0 Nothing)))) (char '-' >> parseNonNumeric True False >>= return . Found)+       return (e, upstreamVersion, debianRevision)++parseEpoch :: CharParser () (Found Int)+parseEpoch =+    option (Simulated 0) (try (many1 digit >>= \d -> char ':' >> return (Found (read d))))+       ++parseNonNumeric :: Bool -> Bool -> CharParser () NonNumeric+parseNonNumeric zeroOk upstream =+    do nn <- (if zeroOk then many else many1) ((noneOf "-0123456789") <|> (if upstream then upstreamDash else pzero))+       n <- parseNumeric upstream+       return $ NonNumeric nn n+    where+      upstreamDash :: CharParser () Char+      upstreamDash = try $ do char '-'+                              lookAhead $ (many (noneOf "- \n\t") >> char '-')+                              return '-'++parseNumeric :: Bool -> CharParser () (Found Numeric)+parseNumeric upstream =+    do n <- many1 (satisfy isDigit)+       nn <- option Nothing  (parseNonNumeric False upstream >>= return . Just)+       return $ Found (Numeric (read n) nn)+    <|>+    return (Simulated (Numeric 0 Nothing))++{-+compareTest :: String -> String -> Ordering+compareTest str1 str2 =+    let v1 = either (error . show) id $ parse parseDV str1 str1+        v2 = either (error . show) id $ parse parseDV str2 str2+        in +          compare v1 v2+-}++-- |Split a DebianVersion into its three components: epoch, version,+-- revision.  It is not safe to use the parsed version number for+-- this because you will lose information, such as leading zeros.+evr :: DebianVersion -> (Maybe Int, String, Maybe String)+evr (DebianVersion s _) =+    let re = mkRegex "^(([0-9]+):)?(([^-]*)|((.*)-([^-]*)))$" in+    --                 (         ) (        (            ))+    --		        (   e  )    (  v  )  (v2) (  r  )+    case matchRegex re s of+      Just ["", _, _, v, "", _, _] -> (Nothing, v, Nothing)+      Just ["", _, _, _, _,  v, r] -> (Nothing, v, Just r)+      Just [_,  e, _, v, "", _, _] -> (Just (read e), v, Nothing)+      Just [_,  e, _, _, _,  v, r] -> (Just (read e), v, Just r)+      -- I really don't think this can happen.+      _ -> error ("Invalid Debian Version String: " ++ s)++epoch :: DebianVersion -> Maybe Int+epoch v = case evr v of (x, _, _) -> x+version :: DebianVersion -> String+version v = case evr v of (_, x, _) -> x+revision :: DebianVersion -> Maybe String+revision v = case evr v of (_, _, x) -> x++-- Build a Debian version number from epoch, version, revision+buildDebianVersion :: Maybe Int -> String -> Maybe String -> DebianVersion+buildDebianVersion e v r =+    either (error . show) (DebianVersion str) $ parse parseDV str str+    where+      str = (maybe "" (\ n -> show n ++ ":") e ++ v ++ maybe "" (\ s -> "-" ++ s) r)

@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Debian.Version.Internal+    ( DebianVersion(..)+    , Numeric(..)+    , NonNumeric(..)+    , Found(..)+    ) where++import Data.Data (Data)+import Data.Typeable (Typeable)++-- Currently we store the original version string in the data-type so+-- that we can faithfully reproduce it quickly. Currently we do not+-- have any way to modify a version number -- so this works fine. May+-- have to change later.+data DebianVersion+    = DebianVersion String (Found Int, NonNumeric, Found NonNumeric) deriving (Data, Typeable)++data NonNumeric+    = NonNumeric String (Found Numeric)+      deriving (Show, Data, Typeable)++data Numeric+    = Numeric Int (Maybe NonNumeric)+      deriving (Show, Data, Typeable)++data Found a+    = Found { unFound :: a }+    | Simulated { unFound :: a }+      deriving (Show, Data, Typeable)++instance (Eq a) => Eq (Found a) where+    f1 == f2 = (unFound f1) == (unFound f2)++instance (Ord a) => Ord (Found a) where+    compare f1 f2 = compare (unFound f1) (unFound f2)

@@ -0,0 +1,25 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS -fno-warn-orphans #-}+module Debian.Version.String+    ( ParseDebianVersion(..)+    ) where++import Text.ParserCombinators.Parsec++import Data.List (stripPrefix)+import Debian.Version.Common+import Debian.Version.Internal++instance ParseDebianVersion String where+    parseDebianVersion str =+        case parse parseDV str str of+          Left e -> error (show e)+          Right dv -> DebianVersion str dv++instance Read DebianVersion where+    readsPrec _ s =+        case stripPrefix "Debian.Version.parseDebianVersion " s of+          Just s' -> case reads s' :: [(String, String)] of+                       []-> []+                       (v, s'') : _ -> [(parseDebianVersion v, s'')]+          Nothing -> []

@@ -0,0 +1,18 @@+{-# OPTIONS -fno-warn-orphans #-}+module Debian.Version.Text+    ( ParseDebianVersion(..)+    ) where++import Text.ParserCombinators.Parsec++import qualified Data.Text as T++import Debian.Version.Common+import Debian.Version.Internal+    +instance ParseDebianVersion T.Text where+    parseDebianVersion text =+        let str = T.unpack text in+        case parse parseDV str str of+          Left e -> error (show e)+          Right dv -> DebianVersion str dv

@@ -7,11 +7,11 @@ -- -- Be sure to run it with the local-debian flag turned off! -import Control.Category ((.))+import OldLens hiding ((%=), (~=))+ import Control.Exception (throw) import Control.Monad.State (get) import Data.Default (def)-import Data.Lens.Lazy (getL, access) import Data.List (intercalate) import Data.Map as Map (insert) import Data.Maybe (fromMaybe)@@ -39,7 +39,7 @@ import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT, GRE), Relations, parseRelations) import Debian.Version (parseDebianVersion) import Distribution.Compiler(CompilerFlavor(GHC))-import Prelude hiding (log, (.))+import Prelude hiding (log) import System.Directory (copyFile)  main :: IO ()@@ -50,10 +50,10 @@        -- This is both a debianization script and a unit test - it        -- makes sure the debianization generated matches the one        -- checked into version control.-       log <- newFlags >>= newCabalInfo >>= evalCabalT (liftCabal inputChangeLog >> access (changelog . debInfo))+       log <- newFlags >>= newCabalInfo >>= evalCabalT (liftCabal inputChangeLog >> access (debInfo . changelog))        old <- newFlags >>= execDebianT inputDebianization . makeDebInfo        new <- newFlags >>= newCabalInfo >>= execCabalT (debianize (do debianDefaults-                                                                      (changelog . debInfo) ~?= log+                                                                      (debInfo . changelog) ~?= log                                                                       customize                                                                       copyFirstLogEntry old))        diff <- compareDebianization old (getL debInfo new)@@ -66,19 +66,19 @@     where       customize :: Monad m => CabalT m ()       customize =-          do (sourceFormat . debInfo) ~= Just Native3-             (standardsVersion . control . debInfo) ~= Just (StandardsVersion 3 9 3 Nothing)-             (compat . debInfo) ~= Just 9-             (utilsPackageNameBase . debInfo) ~= Just "cabal-debian"+          do (debInfo . sourceFormat) ~= Just Native3+             (debInfo . control . standardsVersion) ~= Just (StandardsVersion 3 9 3 Nothing)+             (debInfo . compat) ~= Just 9+             (debInfo . utilsPackageNameBase) ~= Just "cabal-debian"              -- (copyright . debInfo) %= (Just . copyrightFn . fromMaybe def)              -- (conflicts . relations . binaryDebDescription (BinPkgName "cabal-debian") . debInfo) %= (++ (rels "haskell-debian-utils (<< 3.59)"))-             (depends . relations . binaryDebDescription (BinPkgName "cabal-debian") . debInfo) %= (++ (rels "apt-file, debian-policy, debhelper, haskell-devscripts (>= 0.8.19)"))-             (depends . relations . binaryDebDescription (BinPkgName "libghc-cabal-debian-dev") . debInfo) %= (++ (rels "debian-policy"))-             (executable . debInfo) %= (Map.insert (BinPkgName "cabal-debian-tests") (InstallFile "cabal-debian-tests" Nothing Nothing "cabal-debian-tests"))-             (atomSet . debInfo) %= (Set.insert $ InstallCabalExec (BinPkgName "cabal-debian") "cabal-debian" "usr/bin")-             (utilsPackageNameBase . debInfo) ~= Just "cabal-debian"+             (debInfo . binaryDebDescription (BinPkgName "cabal-debian") . relations . depends) %= (++ (rels "apt-file, debian-policy, debhelper, haskell-devscripts (>= 0.8.19)"))+             (debInfo . binaryDebDescription (BinPkgName "libghc-cabal-debian-dev") . relations . depends) %= (++ (rels "debian-policy"))+             (debInfo . executable) %= (Map.insert (BinPkgName "cabal-debian-tests") (InstallFile "cabal-debian-tests" Nothing Nothing "cabal-debian-tests"))+             (debInfo . atomSet) %= (Set.insert $ InstallCabalExec (BinPkgName "cabal-debian") "cabal-debian" "usr/bin")+             (debInfo . utilsPackageNameBase) ~= Just "cabal-debian"              -- extraDevDeps (BinPkgName "debian-policy")-             (homepage . control . debInfo) ~= Just (pack "https://github.com/ddssff/cabal-debian")+             (debInfo . control . homepage) ~= Just (pack "https://github.com/ddssff/cabal-debian")  rels :: String -> Relations rels = either (throw . userError . show) id . parseRelations@@ -90,8 +90,8 @@ copyFirstLogEntry src =     do dst <- get        let Just (ChangeLog (hd1 : _)) = getL changelog src-           Just (ChangeLog (_ : tl2)) = getL (changelog . debInfo) dst-       (changelog . debInfo) ~= Just (ChangeLog (hd1 : tl2))+           Just (ChangeLog (_ : tl2)) = getL (debInfo . changelog) dst+       (debInfo . changelog) ~= Just (ChangeLog (hd1 : tl2)) {-     get >>= \ dst ->  copyFirstLogEntry :: Atoms -> Atoms -> Atoms

@@ -1,3 +1,32 @@+haskell-cabal-debian (4.24.3) unstable; urgency=low++  * Always include the test suite build dependencies in debian/control,+    even if the testEnabled flag is set to False (at the moment it seems+    as if it always is.)++ -- David Fox <dsf@seereason.com>  Mon, 02 Mar 2015 17:33:52 -0800++haskell-cabal-debian (4.24.2) unstable; urgency=low++  * Distinguish between the place we find the data files (dataTop) and the+    place we put then (dataDest)+  * Add a case for the ISC license++ -- David Fox <dsf@seereason.com>  Sun, 22 Feb 2015 15:09:56 -0800++haskell-cabal-debian (4.24.1) unstable; urgency=low++  * Don't assign the name "cabal-ghcjs" to newer Cabal library versions++ -- David Fox <dsf@seereason.com>  Sun, 22 Feb 2015 06:08:28 -0800++haskell-cabal-debian (4.24) unstable; urgency=low++  * Convert from old data-lens package to lens.+  * Implement --allow-debian-self-build-deps++ -- David Fox <dsf@seereason.com>  Sat, 14 Feb 2015 06:15:01 -0800+ haskell-cabal-debian (4.23.1) unstable; urgency=low    * ifdefs for Cabal-1.18, 1.20, and 1.22, ghc-7.6, and 7.8.

@@ -189,6 +189,5 @@ import Debian.Debianize.Output (compareDebianization, describeDebianization, doDebianizeAction, runDebianizeScript, validateDebianization, writeDebianization) import Debian.Debianize.Prelude ((%=), (+++=), (++=), (+=), buildDebVersionMap, debOfFile, dpkgFileMap, withCurrentDirectory, (~=), (~?=)) import Debian.Debianize.SourceDebDescription-import Debian.Debianize.SubstVars (substvars) import Debian.Debianize.VersionSplits (DebBase(DebBase)) import Debian.Policy (accessLogBaseName, apacheAccessLog, apacheErrorLog, apacheLogDirectory, appLogBaseName, Area(..), databaseDirectory, debianPackageVersion, errorLogBaseName, fromCabalLicense, getCurrentDebianUser, getDebhelperCompatLevel, getDebianStandardsVersion, haskellMaintainer, License(..), PackageArchitectures(..), PackagePriority(..), parseMaintainer, parsePackageArchitectures, parseStandardsVersion, parseUploaders, readLicense, readPriority, readSection, readSourceFormat, Section(..), serverAccessLog, serverAppLog, serverLogDirectory, SourceFormat(..), StandardsVersion(..), toCabalLicense)

@@ -26,7 +26,7 @@ import Data.Char (toLower, toUpper) import Data.Default (Default(def)) import Data.Generics (Data, Typeable)-import Data.Lens.Template (nameMakeLens)+import Control.Lens.TH (makeLenses) import Data.Monoid (Monoid(..)) import Data.Set as Set (fromList, Set, union) import Debian.Debianize.Prelude ((%=), read', (~=))@@ -43,30 +43,30 @@ -- or a cabal file from the IO monad. data Flags = Flags     {-      verbosity_ :: Int+      _verbosity :: Int     -- ^ Run with progress messages at the given level of verboseness.-    , dryRun_ :: Bool+    , _dryRun :: Bool     -- ^ Don't write any files or create any directories, just explain     -- what would have been done.-    , validate_ :: Bool+    , _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+    , _debAction :: DebAction     -- ^ What to do - Usage, Debianize or Substvar-    , compilerFlavor_ :: CompilerFlavor+    , _compilerFlavor :: CompilerFlavor     -- ^ Which compiler should we generate library packages for?  In theory a single     -- deb could handle multiple compiler flavors, but the support tools are not ready     -- for this as of right now (28 Jan 2015.)-    , cabalFlagAssignments_ :: Set (FlagName, Bool)+    , _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.-    , buildEnv_ :: EnvSet+    , _buildEnv :: EnvSet     -- ^ Directory containing the build environment for which the     -- debianization will be generated.  This determines which     -- compiler will be available, which in turn determines which@@ -87,20 +87,17 @@  instance Default Flags where     def = Flags-          { verbosity_ = 1-          , debAction_ = Debianize-          , dryRun_ = False-          , validate_ = False-          , compilerFlavor_ = GHC-          , cabalFlagAssignments_ = mempty-          , buildEnv_ = EnvSet {cleanOS = "/", dependOS = "/", buildOS = "/"}+          { _verbosity = 1+          , _debAction = Debianize+          , _dryRun = False+          , _validate = False+          , _compilerFlavor = GHC+          , _cabalFlagAssignments = mempty+          , _buildEnv = EnvSet {cleanOS = "/", dependOS = "/", buildOS = "/"}           }  -- Build the lenses-$(let f s = case s of-              (_ : _) | last s == '_' -> Just (init s)-              _ -> Nothing in-  nameMakeLens ''Flags f)+$(makeLenses ''Flags)  -- | Command line options which build a function that modifies a -- state monad value of type 'Flags'

@@ -30,7 +30,7 @@  import Data.Function (on) import Data.Generics (Data, Typeable)-import Data.Lens.Template (makeLenses)+import Control.Lens.TH (makeLenses) import Data.List (sort, sortBy) import Data.Monoid (Monoid(..)) import Data.Text (Text)@@ -137,4 +137,5 @@       , _replaces = []       , _builtUsing = [] } -$(makeLenses [''BinaryDebDescription, ''PackageRelations])+$(makeLenses ''BinaryDebDescription)+$(makeLenses ''PackageRelations)

@@ -5,13 +5,14 @@     , debianBuildDepsIndep     ) where +import OldLens (access, getL)+ import Control.Applicative ((<$>)) import Control.Category ((.)) import Control.Monad.State (MonadState(get)) import Control.Monad.Trans (MonadIO) import Data.Char (isSpace, toLower) import Data.Function (on)-import Data.Lens.Lazy (access, getL) import Data.List as List (filter, groupBy, map, minimumBy, nub, sortBy) import Data.Map as Map (lookup, Map) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)@@ -26,6 +27,7 @@ import qualified Debian.Debianize.CabalInfo as A import qualified Debian.Debianize.SourceDebDescription as S import Debian.Debianize.VersionSplits (packageRangesFromVersionSplits)+import Debian.GHC (compilerPackageName) import Debian.Orphans () import Debian.Relation (BinPkgName(..), checkVersionReq, Relation(..), Relations) import qualified Debian.Relation as D (BinPkgName(BinPkgName), Relation(..), Relations, VersionReq(EEQ, GRE, LTE, SGR, SLT))@@ -78,7 +80,7 @@       (mergeCabalDependencies $        Cabal.buildDepends pkgDesc ++             concatMap (Cabal.targetBuildDepends . Cabal.buildInfo) (Cabal.executables pkgDesc) ++-            (if noTestSuite then [] else concatMap (Cabal.targetBuildDepends . Cabal.testBuildInfo) $ filter Cabal.testEnabled $ (Cabal.testSuites pkgDesc)))+            (if noTestSuite then [] else concatMap (Cabal.targetBuildDepends . Cabal.testBuildInfo) $ {-filter Cabal.testEnabled-} (Cabal.testSuites pkgDesc)))       (mergeCabalDependencies $ concatMap buildTools $ allBuildInfo pkgDesc)       (mergeCabalDependencies $ concatMap pkgconfigDepends $ allBuildInfo pkgDesc)       (concatMap extraLibs . allBuildInfo $ pkgDesc) >>=@@ -95,7 +97,7 @@       fixDeps :: CabalInfo -> [String] -> Relations       fixDeps atoms xs =           concatMap (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ List.map toLower cab ++ "-dev")) Nothing Nothing]]-                                        (Map.lookup cab (getL (D.extraLibMap . A.debInfo) atoms))) xs+                                        (Map.lookup cab (getL (A.debInfo . D.extraLibMap) atoms))) xs  -- | Take the intersection of all the dependencies on a given package name mergeCabalDependencies :: [Dependency] -> [Dependency]@@ -108,22 +110,20 @@ -- the rules for building haskell packages. debianBuildDeps :: (MonadIO m, Functor m) => PackageDescription -> CabalT m D.Relations debianBuildDeps pkgDesc =-    do hc <- access (compilerFlavor . D.flags . A.debInfo)+    do hc <- access (A.debInfo . D.flags . compilerFlavor)        let hcs = singleton hc -- vestigial        let hcTypePairs =                fold union empty $                   Set.map (\ hc' -> Set.map (hc',) $ hcPackageTypes hc') hcs-       noTestSuite <- access (D.noTestSuite . A.debInfo)+       noTestSuite <- access (A.debInfo . D.noTestSuite)        cDeps <- allBuildDepends noTestSuite pkgDesc >>= mapM (buildDependencies hcTypePairs) >>= return . {-nub .-} concat-       bDeps <- access (S.buildDepends . D.control . A.debInfo)-       prof <- not <$> access (D.noProfilingLibrary . A.debInfo)+       bDeps <- access (A.debInfo . D.control . S.buildDepends)+       prof <- not <$> access (A.debInfo . D.noProfilingLibrary)        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"] ++                       (if member GHC hcs-                       then [anyrel "ghc"] ++ if prof-                                              then [anyrel "ghc-prof"]-                                              else []+                       then [anyrel' (compilerPackageName GHC B.Development)] ++ if prof then [anyrel' (compilerPackageName GHC B.Profiling)] else []                        else []) ++ #if MIN_VERSION_Cabal(1,22,0)                       (if member GHCJS hcs then [anyrel "ghcjs"] else []) ++@@ -142,14 +142,14 @@  debianBuildDepsIndep :: (MonadIO m, Functor m) => PackageDescription -> CabalT m D.Relations debianBuildDepsIndep pkgDesc =-    do hc <- access (compilerFlavor . D.flags . A.debInfo)+    do hc <- access (A.debInfo . D.flags . compilerFlavor)        let hcs = singleton hc -- vestigial-       doc <- not <$> access (D.noDocumentationLibrary . A.debInfo)-       noTestSuite <- access (D.noTestSuite . A.debInfo)-       bDeps <- access (S.buildDependsIndep . D.control . A.debInfo)+       doc <- not <$> access (A.debInfo . D.noDocumentationLibrary)+       noTestSuite <- access (A.debInfo . D.noTestSuite)+       bDeps <- access (A.debInfo . D.control . S.buildDependsIndep)        cDeps <- allBuildDepends noTestSuite pkgDesc >>= mapM docDependencies        let xs = nub $ if doc-                      then (if member GHC hcs then [anyrel "ghc-doc"] else []) +++                      then (if member GHC hcs then [anyrel' (compilerPackageName GHC B.Documentation)] else []) ++ #if MIN_VERSION_Cabal(1,22,0)                            (if member GHCJS hcs then [anyrel "ghcjs"] else []) ++ #endif@@ -162,9 +162,9 @@ -- dependencies, so we have access to all the cross references. docDependencies :: (MonadIO m, Functor m) => Dependency_ -> CabalT m D.Relations docDependencies (BuildDepends (Dependency name ranges)) =-    do hc <- access (compilerFlavor . D.flags . A.debInfo)+    do hc <- access (A.debInfo . D.flags . compilerFlavor)        let hcs = singleton hc -- vestigial-       omitProfDeps <- access (D.omitProfVersionDeps . A.debInfo)+       omitProfDeps <- access (A.debInfo . D.omitProfVersionDeps)        concat <$> mapM (\ hc' -> dependencies hc' B.Documentation name ranges omitProfDeps) (toList hcs) docDependencies _ = return [] @@ -173,15 +173,15 @@ -- references.  Also the packages associated with extra libraries. buildDependencies :: (MonadIO m, Functor m) => Set (CompilerFlavor, B.PackageType) -> Dependency_ -> CabalT m D.Relations buildDependencies hcTypePairs (BuildDepends (Dependency name ranges)) =-    access (D.omitProfVersionDeps . A.debInfo) >>= \ omitProfDeps ->+    access (A.debInfo . D.omitProfVersionDeps) >>= \ omitProfDeps ->     concat <$> mapM (\ (hc, typ) -> dependencies hc typ name ranges omitProfDeps) (toList hcTypePairs) buildDependencies _ dep@(ExtraLibs _) =-    do mp <- access (D.execMap . A.debInfo)+    do mp <- access (A.debInfo . D.execMap)        return $ concat $ adapt mp dep buildDependencies _ dep =     case unboxDependency dep of       Just (Dependency _name _ranges) ->-          do mp <- get >>= return . getL (D.execMap . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.execMap)              return $ concat $ adapt mp dep       Nothing ->           return []@@ -309,7 +309,7 @@       doRel rel@(D.Rel dname req _) = do         -- gver <- access ghcVersion         splits <- access A.debianNameMap-        root <- access (buildEnv . D.flags . A.debInfo) >>= return . dependOS+        root <- access (A.debInfo . D.flags . buildEnv) >>= return . dependOS         -- Look at what version of the package is provided by the compiler.         atoms <- get         -- What version of this package (if any) does the compiler provide?@@ -336,18 +336,6 @@                    Just (D.LTE lver) | Just lver < pver -> compilerDependency ++ libraryDependency                    Just (D.EEQ lver) | Just lver < pver -> compilerDependency ++ libraryDependency                    _ -> libraryDependency ++ compilerDependency-      compilerPackageName GHC B.Documentation = D.BinPkgName "ghc-doc"-      compilerPackageName GHC B.Profiling = D.BinPkgName "ghc-prof"-      compilerPackageName GHC B.Development = D.BinPkgName "ghc"-      compilerPackageName GHC _ = D.BinPkgName "ghc" -- whatevs-#if MIN_VERSION_Cabal(1,22,0)-      compilerPackageName GHCJS B.Documentation = D.BinPkgName "ghcjs"-      compilerPackageName GHCJS B.Profiling = error "Profiling not supported for GHCJS"-      compilerPackageName GHCJS B.Development = D.BinPkgName "ghcjs"-      compilerPackageName GHCJS _ = D.BinPkgName "ghcjs" -- whatevs-#endif-      compilerPackageName x _ = error $ "Unsupported compiler flavor: " ++ show x-       -- FIXME: we are assuming here that ghc conflicts with all the       -- library packages it provides but it no longer conflicts with       -- libghc-cabal-dev.  We can now check these conflicts using the@@ -394,4 +382,4 @@ filterMissing :: Monad m => [[Relation]] -> CabalT m [[Relation]] filterMissing rels =     get >>= \ atoms -> return $-    List.filter (/= []) (List.map (List.filter (\ (Rel name _ _) -> not (Set.member name (getL (D.missingDependencies . A.debInfo) atoms)))) rels)+    List.filter (/= []) (List.map (List.filter (\ (Rel name _ _) -> not (Set.member name (getL (A.debInfo . D.missingDependencies) atoms)))) rels)

@@ -17,19 +17,20 @@     , newCabalInfo     ) where +import OldLens (access)+ import Control.Category ((.))-import Control.Monad (unless)+import Control.Lens.TH (makeLenses)+import Control.Monad (unless, when) import Control.Monad.State (execStateT) import Control.Monad.Trans (liftIO) import Data.Generics (Data, Typeable)-import Data.Lens.Lazy (access)-import Data.Lens.Template (nameMakeLens)-import Data.List as List (init, null)+import Data.List as List (null) import Data.Map as Map (Map) import Data.Monoid (Monoid(..)) import Data.Text as Text (null, pack, strip) import Debian.Debianize.BasicInfo (Flags)-import Debian.Debianize.DebInfo as D (control, copyright, DebInfo, makeDebInfo, noTestSuite, rulesSettings)+import Debian.Debianize.DebInfo as D (control, copyright, DebInfo, makeDebInfo, noTestSuite, rulesSettings, official) import Debian.Debianize.BinaryDebDescription (Canonical(canonical)) import Debian.Debianize.CopyrightDescription (defaultCopyrightDescription) import Debian.Debianize.InputCabal (inputCabalization)@@ -59,18 +60,18 @@ -- debianization is finalized. data CabalInfo     = CabalInfo-      { packageDescription_ :: PackageDescription+      { _packageDescription :: PackageDescription       -- ^ The result of reading a cabal configuration file.-      , debInfo_ :: DebInfo+      , _debInfo :: DebInfo       -- ^ Information required to represent a non-cabal debianization.-      , debianNameMap_ :: Map PackageName VersionSplits+      , _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.-      , epochMap_ :: Map PackageName Int+      , _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+      , _packageInfo :: Map PackageName PackageInfo       -- ^ Supply some info about a cabal package.       } deriving (Show, Data, Typeable) @@ -79,13 +80,10 @@                                , profDeb :: Maybe (BinPkgName, DebianVersion)                                , docDeb :: Maybe (BinPkgName, DebianVersion) } deriving (Eq, Ord, Show, Data, Typeable) -$(let f s = case s of-              (_ : _) | last s == '_' -> Just (init s)-              _ -> Nothing in-  nameMakeLens ''CabalInfo f)+$(makeLenses ''CabalInfo)  instance Canonical CabalInfo where-    canonical x = x {debInfo_ = canonical (debInfo_ x)}+    canonical x = x {_debInfo = canonical (_debInfo x)}  -- | Given the 'Flags' value read the cabalization and build a new -- 'CabalInfo' record.@@ -94,23 +92,21 @@   pkgDesc <- inputCabalization flags'   copyrt <- liftIO $ defaultCopyrightDescription pkgDesc   execStateT-    (do (copyright . debInfo) ~= Just copyrt-        (S.homepage . control . debInfo) ~= case strip (pack (Cabal.homepage pkgDesc)) of+    (do (debInfo . copyright) ~= Just copyrt+        (debInfo . control . S.homepage) ~= case strip (pack (Cabal.homepage pkgDesc)) of                                               x | Text.null x -> Nothing                                               x -> Just x-        noTests <- access (noTestSuite . debInfo)+        noTests <- access (debInfo . noTestSuite)         unless (List.null (Cabal.testSuites pkgDesc) || noTests)-               (do (rulesSettings . debInfo) %= (++ ["DEB_ENABLE_TESTS = yes", "DEB_BUILD_OPTIONS += nocheck"])-                   -- ...-               ))+               (do (debInfo . rulesSettings) %= (++ ["DEB_ENABLE_TESTS = yes", "DEB_BUILD_OPTIONS += nocheck"])))     (makeCabalInfo flags' pkgDesc)  makeCabalInfo :: Flags -> PackageDescription -> CabalInfo makeCabalInfo fs pkgDesc =     CabalInfo-      { packageDescription_ = pkgDesc-      , epochMap_ = mempty-      , packageInfo_ = mempty-      , debianNameMap_ = mempty-      , debInfo_ = makeDebInfo fs+      { _packageDescription = pkgDesc+      , _epochMap = mempty+      , _packageInfo = mempty+      , _debianNameMap = mempty+      , _debInfo = makeDebInfo fs       }

@@ -28,7 +28,7 @@ import Data.Char (isSpace) import Data.Default (Default(def)) import Data.Generics (Data, Typeable)-import Data.Lens.Template (makeLenses)+import Control.Lens.TH (makeLenses) import Data.List as List (dropWhileEnd, partition) import Data.Maybe (isJust, catMaybes, fromJust, fromMaybe, listToMaybe) import Data.Monoid ((<>), mempty)@@ -37,7 +37,7 @@ import Debian.Debianize.Prelude (readFileMaybe) import Debian.Orphans () import Debian.Policy (License(..), readLicense, fromCabalLicense)-import Debian.Pretty (PP(PP, unPP), display', ppDisplay', ppPrint)+import Debian.Pretty (prettyText, ppText) import qualified Distribution.License as Cabal (License(UnknownLicense)) #if MIN_VERSION_Cabal(1,20,0) import qualified Distribution.PackageDescription as Cabal (PackageDescription(licenseFiles, copyright, license))@@ -78,10 +78,10 @@       , _comment :: Maybe Text       } deriving (Eq, Ord, Show, Data, Typeable) -instance Pretty (PP CopyrightDescription) where+instance Pretty CopyrightDescription where     -- Special case encodes free format debian/copyright file-    pPrint (PP x@(CopyrightDescription {_summaryComment = Just t})) | x {_summaryComment = Nothing} == def = text (List.dropWhileEnd isSpace (unpack t) <> "\n")-    pPrint x = ppPrint . toControlFile . unPP $ x+    pPrint x@(CopyrightDescription {_summaryComment = Just t}) | x {_summaryComment = Nothing} == def = text (List.dropWhileEnd isSpace (unpack t) <> "\n")+    pPrint x = pPrint . toControlFile $ x  instance Default CopyrightDescription where     def = CopyrightDescription@@ -148,12 +148,12 @@ toControlFile d =     Control     ( Paragraph-      ( [ Field ("Format", (" " <> ppDisplay' (_format d))) ] +++      ( [ Field ("Format", (" " <> ppText (_format d))) ] ++         maybe [] (\x -> [Field ("Upstream-Name", " " <> x)]) (_upstreamName d) ++         maybe [] (\x -> [Field ("Upstream-Contact", " " <> x)]) (_upstreamContact d) ++         maybe [] (\x -> [Field ("Source", " " <> x)]) (_upstreamSource d) ++         maybe [] (\x -> [Field ("Disclaimer", " " <> x)]) (_disclaimer d) ++-        maybe [] (\x -> [Field ("License", " " <> display' x)]) (_summaryLicense d) +++        maybe [] (\x -> [Field ("License", " " <> prettyText x)]) (_summaryLicense d) ++         maybe [] (\x -> [Field ("Copyright", " " <> x)]) (_summaryCopyright d) ++         maybe [] (\x -> [Field ("Comment", " " <> x)]) (_summaryComment d)) :       map toParagraph (_filesAndLicenses d) )@@ -163,11 +163,11 @@     Paragraph $       [ Field ("Files", " " <> pack (_filesPattern fd))       , Field ("Copyright", " " <> _filesCopyright fd)-      , Field ("License", " " <> display' (_filesLicense fd)) ] +++      , Field ("License", " " <> prettyText (_filesLicense fd)) ] ++       maybe [] (\ t -> [Field ("Comment", " " <> t)]) (_filesComment fd) toParagraph ld@LicenseDescription {} =     Paragraph $-      [ Field ("License", " " <> display' (_license ld)) ] +++      [ Field ("License", " " <> prettyText (_license ld)) ] ++       maybe [] (\ t -> [Field ("Comment", " " <> t)]) (_comment ld)  -- | Infer a 'CopyrightDescription' from a Cabal package description.@@ -241,4 +241,5 @@ dots :: Text -> Text dots = Text.unlines . map (\ line -> if Text.null line then "." else line) . map (Text.dropWhileEnd isSpace) . Text.lines -$(makeLenses [''CopyrightDescription, ''FilesOrLicenseDescription])+$(makeLenses ''CopyrightDescription)+$(makeLenses ''FilesOrLicenseDescription)

@@ -1,7 +1,7 @@ -- | 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 CPP, DeriveDataTypeable, TemplateHaskell #-}+{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types, TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} module Debian.Debianize.DebInfo     ( -- * Types@@ -86,14 +86,13 @@     , makeDebInfo     ) where +import OldLens (Lens, iso, getL, (%=))+ import Control.Category ((.)) import Control.Monad.State (StateT) --import Data.Default (def) import Data.Generics (Data, Typeable)-import Data.Lens.Common (Lens, iso, getL)-import Data.Lens.Lazy ((%=))-import Data.Lens.Template (nameMakeLens)-import Data.List (init)+import Control.Lens.TH (makeLenses) import Data.Map as Map (Map) import Data.Monoid (Monoid(..)) import Data.Set as Set (insert, Set)@@ -115,60 +114,60 @@ -- | Information required to represent a non-cabal debianization. data DebInfo     = DebInfo-      { flags_ :: Flags+      { _flags :: Flags       -- ^ Information regarding mode of operation - verbosity, dry-run, usage, etc-      , warning_ :: Set Text+      , _warning :: Set Text       -- ^ A warning to be reported later-      , sourceFormat_ :: Maybe SourceFormat+      , _sourceFormat :: Maybe SourceFormat       -- ^ Write debian/source/format-      , watch_ :: Maybe Text+      , _watch :: Maybe Text       -- ^ the @debian\/watch@ file-      , rulesHead_ :: Maybe Text+      , _rulesHead :: Maybe Text       -- ^ The rules file header-      , rulesSettings_ :: [Text]+      , _rulesSettings :: [Text]       -- ^ The rules file assignments-      , rulesIncludes_ :: [Text]+      , _rulesIncludes :: [Text]       -- ^ The rules file include directives-      , rulesFragments_ :: Set Text+      , _rulesFragments :: Set Text       -- ^ Additional fragments of the rules file-      , copyright_ :: Maybe CopyrightDescription+      , _copyright :: Maybe CopyrightDescription       -- ^ Override the copyright value computed from the cabal package description.-      , control_ :: S.SourceDebDescription+      , _control :: S.SourceDebDescription       -- ^ The parsed contents of the control file-      , intermediateFiles_ :: Set (FilePath, Text)+      , _intermediateFiles :: Set (FilePath, Text)       -- ^ Put this text into a file with the given name in the debianization.-      , compat_ :: Maybe Int+      , _compat :: Maybe Int       -- ^ The debhelper compatibility level, from debian/compat.-      , changelog_ :: Maybe ChangeLog+      , _changelog :: Maybe ChangeLog       -- ^ The changelog, first entry contains the source package name and version-      , installInit_ :: Map BinPkgName Text+      , _installInit :: Map BinPkgName Text       -- ^ Add an init.d file to the binary package-      , logrotateStanza_ :: Map BinPkgName (Set Text)+      , _logrotateStanza :: Map BinPkgName (Set Text)       -- ^ Add a stanza of a logrotate file to the binary package-      , postInst_ :: Map BinPkgName Text+      , _postInst :: Map BinPkgName Text       -- ^ Map of @debian/postinst@ scripts - to be run after install,       -- should contain #DEBHELPER# line before exit 0-      , postRm_ :: Map BinPkgName Text+      , _postRm :: Map BinPkgName Text       -- ^ Map of @debian/postrm@ scripts - scripts to run after       -- remove, should contain #DEBHELPER# line before exit 0-      , preInst_ :: Map BinPkgName Text+      , _preInst :: Map BinPkgName Text       -- ^ Map of @debian/preinst@ scripts - to be run before install,       -- should contain #DEBHELPER# line before exit 0-      , preRm_ :: Map BinPkgName Text+      , _preRm :: Map BinPkgName Text       -- ^ Map of @debian/prerm@ scripts - to be run before remove,       -- should contain #DEBHELPER# line before exit 0-      , atomSet_ :: Set Atom+      , _atomSet :: Set Atom       -- ^ set of items describing file installation requests-      , noDocumentationLibrary_ :: Bool+      , _noDocumentationLibrary :: Bool       -- ^ Do not produce a libghc-foo-doc package.-      , noProfilingLibrary_ :: Bool+      , _noProfilingLibrary :: Bool       -- ^ Do not produce a libghc-foo-prof package.-      , omitProfVersionDeps_ :: Bool+      , _omitProfVersionDeps :: Bool       -- ^ If present, Do not put the version dependencies on the prof packages that we put on the dev packages.-      , omitLTDeps_ :: Bool+      , _omitLTDeps :: Bool       -- ^ If present, don't generate the << dependency when we see a cabal       -- equals dependency.  (The implementation of this was somehow lost.)-      , buildDir_ :: Maybe FilePath+      , _buildDir :: Maybe 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@@ -176,19 +175,19 @@       -- 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-      , sourcePackageName_ :: Maybe SrcPkgName+      , _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.-      , overrideDebianNameBase_ :: Maybe DebBase+      , _overrideDebianNameBase :: Maybe DebBase       -- ^ If given, use this name for the base of the debian binary       -- packages - the string between 'libghc-' and '-dev'.  Normally       -- this is derived from the hackage package name.-      , revision_ :: Maybe String+      , _revision :: Maybe String       -- ^ Specify the revision string to use when converting the       -- cabal version to debian.-      , debVersion_ :: Maybe DebianVersion+      , _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@@ -197,64 +196,64 @@       -- 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.-      , maintainerOption_ :: Maybe NameAddr-      , uploadersOption_ :: [NameAddr]+      , _maintainerOption :: Maybe NameAddr+      , _uploadersOption :: [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.-      , utilsPackageNameBase_ :: Maybe String+      , _utilsPackageNameBase :: Maybe String       -- ^ 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.-      , xDescriptionText_ :: Maybe Text+      , _xDescriptionText :: Maybe Text       -- ^ The text for the X-Description field of the Source package stanza.-      , comments_ :: Maybe [[Text]]+      , _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+      , _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+      , _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+      , _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.-      , apacheSite_ :: Map BinPkgName (String, FilePath, Text)+      , _apacheSite :: Map BinPkgName (String, FilePath, Text)       -- ^ Have Apache configure a site using PACKAGE, DOMAIN, LOGDIR, and APACHECONFIGFILE-      , sourceArchitectures_ :: Maybe PackageArchitectures+      , _sourceArchitectures :: Maybe PackageArchitectures       -- ^ Set the Architecture field of the source package-      , binaryArchitectures_ :: Map BinPkgName PackageArchitectures+      , _binaryArchitectures :: Map BinPkgName PackageArchitectures       -- ^ Set the Architecture field of a binary package-      , sourcePriority_ :: Maybe PackagePriority+      , _sourcePriority :: Maybe PackagePriority       -- ^ Set the Priority field of the source package-      , binaryPriorities_ :: Map BinPkgName PackagePriority+      , _binaryPriorities :: Map BinPkgName PackagePriority       -- ^ Set the Priority field of a binary package-      , sourceSection_ :: Maybe Section+      , _sourceSection :: Maybe Section       -- ^ Set the Section field of the source package-      , binarySections_ :: Map BinPkgName Section+      , _binarySections :: Map BinPkgName Section       -- ^ Set the Section field of a binary package-      , executable_ :: Map BinPkgName InstallFile+      , _executable :: Map BinPkgName InstallFile       -- ^ Create a binary package to hold a cabal executable-      , serverInfo_ :: Map BinPkgName Server+      , _serverInfo :: Map BinPkgName Server       -- ^ Like DHExecutable, but configure the executable as a server process-      , website_ :: Map BinPkgName Site+      , _website :: Map BinPkgName Site       -- ^ Like DHServer, but configure the server as a web server-      , backups_ :: Map BinPkgName String+      , _backups :: Map BinPkgName String       -- ^ Configure the executable to do incremental backups-      , extraDevDeps_ :: Relations+      , _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.-      , official_ :: Bool+      , _official :: Bool       -- ^ Whether this packaging is created by the Debian Haskell Group-      , noTestSuite_ :: Bool+      , _noTestSuite :: Bool       -- ^ Force omission of the test suites from the debianization-      , allowDebianSelfBuildDeps_ :: Bool+      , _allowDebianSelfBuildDeps :: Bool       -- ^ Normally self dependencies are filtered out of the debian       -- build dependency list because they usually reflect       -- interdependencies between the library and the executable in@@ -316,67 +315,64 @@ makeDebInfo :: Flags -> DebInfo makeDebInfo fs =     DebInfo-    { flags_ = fs-    , warning_ = mempty-    , sourceFormat_ = Nothing-    , watch_ = Nothing-    , rulesHead_ = Nothing-    , rulesSettings_ = mempty-    , rulesIncludes_ = mempty-    , rulesFragments_ = mempty-    , copyright_ = Nothing-    , control_ = S.newSourceDebDescription-    , intermediateFiles_ = mempty-    , compat_ = Nothing-    , changelog_ = Nothing-    , installInit_ = mempty-    , logrotateStanza_ = mempty-    , postInst_ = mempty-    , postRm_ = mempty-    , preInst_ = mempty-    , preRm_ = mempty-    , atomSet_ = mempty-    , noDocumentationLibrary_ = False-    , noProfilingLibrary_ = False-    , omitProfVersionDeps_ = False-    , omitLTDeps_ = False-    , buildDir_ = Nothing-    , sourcePackageName_ = Nothing-    , overrideDebianNameBase_ = Nothing-    , revision_ = Nothing-    , debVersion_ = Nothing-    , maintainerOption_ = Nothing-    , uploadersOption_ = []-    , utilsPackageNameBase_ = Nothing-    , xDescriptionText_ = Nothing-    , comments_ = Nothing-    , missingDependencies_ = mempty-    , extraLibMap_ = mempty-    , execMap_ = mempty-    , apacheSite_ = mempty-    , sourceArchitectures_ = Nothing-    , binaryArchitectures_ = mempty-    , sourcePriority_ = Nothing-    , binaryPriorities_ = mempty-    , sourceSection_ = Nothing-    , binarySections_ = mempty-    , executable_ = mempty-    , serverInfo_ = mempty-    , website_ = mempty-    , backups_ = mempty-    , extraDevDeps_ = mempty-    , official_ = False-    , noTestSuite_ = False-    , allowDebianSelfBuildDeps_ = False+    { _flags = fs+    , _warning = mempty+    , _sourceFormat = Nothing+    , _watch = Nothing+    , _rulesHead = Nothing+    , _rulesSettings = mempty+    , _rulesIncludes = mempty+    , _rulesFragments = mempty+    , _copyright = Nothing+    , _control = S.newSourceDebDescription+    , _intermediateFiles = mempty+    , _compat = Nothing+    , _changelog = Nothing+    , _installInit = mempty+    , _logrotateStanza = mempty+    , _postInst = mempty+    , _postRm = mempty+    , _preInst = mempty+    , _preRm = mempty+    , _atomSet = mempty+    , _noDocumentationLibrary = False+    , _noProfilingLibrary = False+    , _omitProfVersionDeps = False+    , _omitLTDeps = False+    , _buildDir = Nothing+    , _sourcePackageName = Nothing+    , _overrideDebianNameBase = Nothing+    , _revision = Nothing+    , _debVersion = Nothing+    , _maintainerOption = Nothing+    , _uploadersOption = []+    , _utilsPackageNameBase = Nothing+    , _xDescriptionText = Nothing+    , _comments = Nothing+    , _missingDependencies = mempty+    , _extraLibMap = mempty+    , _execMap = mempty+    , _apacheSite = mempty+    , _sourceArchitectures = Nothing+    , _binaryArchitectures = mempty+    , _sourcePriority = Nothing+    , _binaryPriorities = mempty+    , _sourceSection = Nothing+    , _binarySections = mempty+    , _executable = mempty+    , _serverInfo = mempty+    , _website = mempty+    , _backups = mempty+    , _extraDevDeps = mempty+    , _official = False+    , _noTestSuite = False+    , _allowDebianSelfBuildDeps = False     }  instance Canonical DebInfo where-    canonical x = x {control_ = canonical (control_ x)}+    canonical x = x {_control = canonical (_control x)} -$(let f s = case s of-              (_ : _) | last s == '_' -> Just (init s)-              _ -> Nothing in-  nameMakeLens ''DebInfo f)+$(makeLenses ''DebInfo)  -- We need (%=_) link :: Monad m => BinPkgName -> FilePath -> FilePath -> StateT DebInfo m ()@@ -399,4 +395,5 @@ -- | Lens to look up the binary deb description by name and create it if absent. -- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package> binaryDebDescription :: BinPkgName -> Lens DebInfo BinaryDebDescription-binaryDebDescription b = maybeLens (newBinaryDebDescription b) (iso id id) . listElemLens ((== b) . getL package) . S.binaryPackages . control+binaryDebDescription b =+    control . S.binaryPackages . listElemLens ((== b) . getL package) . maybeLens (newBinaryDebDescription b) (iso id id)

@@ -11,10 +11,11 @@     , remapCabal     ) where +import OldLens (access)+ import Control.Applicative ((<$>)) import Control.Category ((.)) import Data.Char (toLower)-import Data.Lens.Lazy (access) import Data.Map as Map (alter, lookup) import Data.Version (showVersion, Version) import Debian.Debianize.Monad (CabalT)@@ -44,8 +45,8 @@ debianName typ cfl =     do base <-            case (typ, cfl) of-             (Utilities, GHC) -> access (utilsPackageNameBase . debInfo) >>= maybe (((\ base -> "haskell-" ++ base ++ "-utils") . unDebBase) <$> debianNameBase) return-             (Utilities, _) -> access (utilsPackageNameBase . debInfo) >>= maybe (((\ base -> base ++ "-utils") . unDebBase) <$> debianNameBase) return+             (Utilities, GHC) -> access (debInfo . utilsPackageNameBase) >>= maybe (((\ base -> "haskell-" ++ base ++ "-utils") . unDebBase) <$> debianNameBase) return+             (Utilities, _) -> access (debInfo . utilsPackageNameBase) >>= maybe (((\ base -> base ++ "-utils") . unDebBase) <$> debianNameBase) return              _ -> unDebBase <$> debianNameBase        return $ mkPkgName' cfl typ (DebBase base) @@ -55,7 +56,7 @@ -- is >= v. debianNameBase :: Monad m => CabalT m DebBase debianNameBase =-    do nameBase <- access (D.overrideDebianNameBase . debInfo)+    do nameBase <- access (debInfo . D.overrideDebianNameBase)        pkgDesc <- access packageDescription        let pkgId = Cabal.package pkgDesc        nameMap <- access A.debianNameMap

@@ -27,11 +27,7 @@        A.epochMap ++= (PackageName "HaXml", 1)        A.epochMap ++= (PackageName "HTTP", 1)        -- The hsx2hs build tool is in an an eponymous deb-       (D.execMap . A.debInfo) ++= ("hsx2hs", [[Rel (BinPkgName "hsx2hs") Nothing Nothing]])-       -- For now, use deb names like libghc-cabal-ghcjs-dev for any-       -- Cabal >= 1.21, which is the ghcjs development branch of Cabal.-       mapCabal (PackageName "Cabal") (DebBase "cabal-ghcjs")-       splitCabal (PackageName "Cabal") (DebBase "cabal") (Version [1,21] [])+       (A.debInfo . D.execMap) ++= ("hsx2hs", [[Rel (BinPkgName "hsx2hs") Nothing Nothing]])        -- The parsec debs are suffixed with either "2" or "3"        mapCabal (PackageName "parsec") (DebBase "parsec3")        splitCabal (PackageName "parsec") (DebBase "parsec2") (Version [3] [])

@@ -6,12 +6,13 @@     ( debianizationFileMap     ) where +import OldLens (access, getL)+ import Control.Applicative ((<$>)) import Control.Category ((.)) import Control.Monad.Trans (lift) import Control.Monad.Writer (execWriterT, tell, WriterT) import Data.Char (isSpace)-import Data.Lens.Lazy (access, getL) import Data.List as List (dropWhile, dropWhileEnd, map) import Data.Map as Map (fromListWithKey, insertWith, map, Map, mapKeys, toList) import Data.Maybe (fromMaybe)@@ -26,7 +27,7 @@ import qualified Debian.Debianize.BinaryDebDescription as B (architecture, BinaryDebDescription, binaryPriority, binarySection, breaks, builtUsing, conflicts, depends, description, essential, package, PackageRelations, preDepends, provides, recommends, relations, replaces, suggests) import Debian.Debianize.CopyrightDescription (CopyrightDescription) import qualified Debian.Debianize.SourceDebDescription as S (binaryPackages, buildConflicts, buildConflictsIndep, buildDepends, buildDependsIndep, dmUploadAllowed, homepage, maintainer, priority, section, source, SourceDebDescription, standardsVersion, uploaders, vcsFields, VersionControlSpec(VCSArch, VCSBrowser, VCSBzr, VCSCvs, VCSDarcs, VCSGit, VCSHg, VCSMtn, VCSSvn), xDescription, XField(XField), XFieldDest(B, C, S), xFields)-import Debian.Pretty (PP(..), ppDisplay, ppDisplay', ppPrint)+import Debian.Pretty (PP(..), ppShow, prettyText, ppText, ppPrint) import Debian.Relation (BinPkgName(BinPkgName), Relations) import Distribution.PackageDescription (PackageDescription) import Prelude hiding ((.), dropWhile, init, log, unlines, writeFile)@@ -69,7 +70,7 @@  sourceFormatFiles :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] sourceFormatFiles =-    maybe [] (\ x -> [("debian/source/format", pack (ppDisplay x))]) <$> (lift $ access D.sourceFormat)+    maybe [] (\ x -> [("debian/source/format", pack (ppShow x))]) <$> (lift $ access D.sourceFormat)  watchFile :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] watchFile = maybe [] (\ x -> [("debian/watch", x)]) <$> (lift $ access D.watch)@@ -155,7 +156,7 @@ control :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] control =     do d <- lift $ access D.control-       return [("debian/control", ppDisplay' (controlFile d))]+       return [("debian/control", prettyText (controlFile d))]  compat :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] compat =@@ -165,7 +166,7 @@ copyright :: (Monad m, Functor m) => FilesT m [(FilePath, Text)] copyright =     do copyrt <- lift $ access (D.copyright)-       return [("debian/copyright", ppDisplay' copyrt)]+       return [("debian/copyright", prettyText copyrt)]  instance Pretty (PP (PackageDescription -> IO CopyrightDescription)) where     pPrint _ = text "<function>"@@ -206,10 +207,10 @@           where             ensureDescription t =                 case List.dropWhileEnd Text.null (List.dropWhile Text.null (List.map (Text.dropWhileEnd isSpace) (Text.lines t))) of-                  [] -> "WARNING: No description available for package " <> ppDisplay' (getL B.package bin)+                  [] -> "WARNING: No description available for package " <> ppText (getL B.package bin)                   (short : long) ->                       Text.intercalate "\n"-                        ((if Text.null (Text.dropWhile isSpace short) then ("WARNING: No short description available for package " <> ppDisplay' (getL B.package bin)) else short) : long)+                        ((if Text.null (Text.dropWhile isSpace short) then ("WARNING: No short description available for package " <> ppText (getL B.package bin)) else short) : long)       mField tag = maybe [] (\ x -> [Field (tag, " " <> (show . ppPrint $ x))])       lField _ [] = []       lField tag xs = [Field (tag, " " <> (show . ppPrint $ xs))]

@@ -5,6 +5,8 @@     -- , finalizeDebianization -- external use deprecated - used in test script     ) where +import OldLens (access, getL)+ import Control.Applicative ((<$>)) import Control.Category ((.)) import Control.Monad (unless, when)@@ -14,7 +16,6 @@ import Data.ByteString.Lazy.UTF8 (fromString) import Data.Char (toLower) import Data.Digest.Pure.MD5 (md5)-import Data.Lens.Lazy (access, getL) import Data.List as List (filter, intercalate, map, nub, null, unlines) import Data.Map as Map (delete, elems, insertWith, lookup, Map, toList) import Data.Maybe (fromMaybe, isJust, isNothing)@@ -30,7 +31,7 @@ import qualified Debian.Debianize.DebInfo as D import Debian.Debianize.DebianName (debianName, debianNameBase) import Debian.Debianize.Goodies (backupAtoms, describe, execAtoms, serverAtoms, siteAtoms, watchAtom)-import Debian.Debianize.InputDebian (dataDir, inputChangeLog)+import Debian.Debianize.InputDebian (dataTop, dataDest, inputChangeLog) import Debian.Debianize.Monad as Monad (CabalT, liftCabal) import Debian.Debianize.Options (compileCommandlineArgs, compileEnvironmentArgs) import Debian.Debianize.Prelude ((%=), (+=), (~=), (~?=))@@ -40,7 +41,7 @@ import Debian.Debianize.VersionSplits (DebBase(DebBase)) import Debian.Orphans () import Debian.Policy (getCurrentDebianUser, getDebhelperCompatLevel, haskellMaintainer, PackageArchitectures(Any, All), PackagePriority(Extra), parseMaintainer, parseStandardsVersion, Section(..), SourceFormat(Native3, Quilt3))-import Debian.Pretty (PP(..), ppDisplay)+import Debian.Pretty (PP(..), ppShow) import Debian.Relation (BinPkgName, BinPkgName(BinPkgName), Relation(Rel), Relations, SrcPkgName(SrcPkgName)) import qualified Debian.Relation as D (BinPkgName(BinPkgName), Relation(..)) import Debian.Release (parseReleaseName)@@ -53,7 +54,7 @@ import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName(PackageName)) import Distribution.PackageDescription (FlagName(FlagName), PackageDescription) import Distribution.PackageDescription as Cabal (allBuildInfo, author, BuildInfo(buildable, extraLibs), Executable(buildInfo, exeName), maintainer)-import qualified Distribution.PackageDescription as Cabal (PackageDescription(dataDir, dataFiles, executables, library, package))+import qualified Distribution.PackageDescription as Cabal (PackageDescription(dataFiles, executables, library, package)) import Paths_cabal_debian (version) import Prelude hiding ((.), init, log, map, unlines, unlines, writeFile) import System.Environment (getProgName)@@ -80,7 +81,7 @@     do date <- liftIO getCurrentLocalRFC822Time        debhelperCompat <- liftIO getDebhelperCompatLevel        finalizeDebianization' date debhelperCompat-       vb <- access (verbosity . D.flags . A.debInfo)+       vb <- access (A.debInfo . D.flags . verbosity)        when (vb >= 3) (get >>= \ x -> liftIO (putStrLn ("\nFinalized Cabal Info: " ++ show x ++ "\n")))  -- | Now that we know the build and data directories, we can expand@@ -94,32 +95,33 @@ finalizeDebianization'  :: (MonadIO m, Functor m) => String -> Maybe Int -> CabalT m () finalizeDebianization' date debhelperCompat =     do -- In reality, hcs must be a singleton or many things won't work.  But some day...-       hc <- access (compilerFlavor . D.flags . A.debInfo)+       hc <- access (A.debInfo . D.flags . compilerFlavor)        finalizeSourceName B.HaskellSource        checkOfficialSettings hc        addExtraLibDependencies hc        pkgDesc <- access A.packageDescription-       (D.watch . A.debInfo) ~?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))-       (S.section . D.control . A.debInfo) ~?= Just (MainSection "haskell")-       (S.priority . D.control . A.debInfo) ~?= Just Extra-       (D.sourceFormat . A.debInfo) ~?= Just Quilt3-       (D.compat . A.debInfo) ~?= debhelperCompat+       (A.debInfo . D.watch) ~?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))+       (A.debInfo . D.control . S.section) ~?= Just (MainSection "haskell")+       (A.debInfo . D.control . S.priority) ~?= Just Extra+       (A.debInfo . D.sourceFormat) ~?= Just Quilt3+       (A.debInfo . D.compat) ~?= debhelperCompat        finalizeChangelog date        finalizeControl        finalizeRules        -- T.license ~?= Just (Cabal.license pkgDesc)        expandAtoms        -- Create the binary packages for the web sites, servers, backup packges, and other executables-       access (D.executable . A.debInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList-       access (D.backups . A.debInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList-       access (D.serverInfo . A.debInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList-       access (D.website . A.debInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList+       access (A.debInfo . D.executable) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList+       access (A.debInfo . D.backups) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList+       access (A.debInfo . D.serverInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList+       access (A.debInfo . D.website) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList        -- Make sure all the control file sections exist before doing the build dependencies,        -- because we need to filter out self dependencies.        librarySpecs pkgDesc hc        makeUtilsPackage pkgDesc hc-       debs <- access (S.binaryPackages . D.control . A.debInfo) >>= return . List.map (getL B.package)-       putBuildDeps debs pkgDesc+       debs <- access (A.debInfo . D.control . S.binaryPackages) >>= return . List.map (getL B.package)+       allowSelfDeps <- access (A.debInfo . D.allowDebianSelfBuildDeps)+       putBuildDeps (if allowSelfDeps then id else filterRelations debs) 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@@ -152,23 +154,23 @@     do pkgDesc <- access A.packageDescription        let pkgId = Cabal.package pkgDesc        epoch <- debianEpoch (pkgName pkgId)-       debVer <- access (D.debVersion . A.debInfo)+       debVer <- access (A.debInfo . D.debVersion)        case debVer of          Just override-             | override < parseDebianVersion (ppDisplay (pkgVersion pkgId)) ->-                 error ("Version from --deb-version (" ++ ppDisplay override ++-                        ") is older than hackage version (" ++ ppDisplay (pkgVersion pkgId) +++             | override < parseDebianVersion (ppShow (pkgVersion pkgId)) ->+                 error ("Version from --deb-version (" ++ ppShow override +++                        ") is older than hackage version (" ++ ppShow (pkgVersion pkgId) ++                         "), maybe you need to unpin this package?")          Just override -> return override          Nothing ->-             do let ver = ppDisplay (pkgVersion pkgId)-                rev <- access (D.revision . A.debInfo)+             do let ver = ppShow (pkgVersion pkgId)+                rev <- access (A.debInfo . D.revision)                 let rev'  = case rev of Nothing -> Nothing                                         Just "" -> Nothing                                         Just "-" -> Nothing                                         Just ('-':r) -> Just r                                         Just _ -> error "The Debian revision needs to start with a dash"-                fmt <- access (D.sourceFormat . A.debInfo)+                fmt <- access (A.debInfo . D.sourceFormat)                 -- If no revision number has been set and the format                 -- is not Native3 we need to set it (see                 -- https://github.com/ddssff/cabal-debian/issues/16)@@ -188,7 +190,7 @@ finalizeSourceName :: (Monad m, Functor m) => B.PackageType -> CabalT m () finalizeSourceName typ =     do DebBase debName <- debianNameBase-       (D.sourcePackageName . A.debInfo) ~?= Just (SrcPkgName (case typ of+       (A.debInfo . D.sourcePackageName) ~?= Just (SrcPkgName (case typ of                                                    B.HaskellSource -> "haskell-" ++ debName                                                    B.Source -> debName                                                    _ -> error $ "finalizeSourceName: " ++ show typ))@@ -206,17 +208,17 @@ -- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Uploaders> finalizeMaintainer :: MonadIO m => CabalT m () finalizeMaintainer = do-  o <- access (D.official . A.debInfo)+  o <- access (A.debInfo . D.official)   currentUser <- liftIO getCurrentDebianUser   pkgDesc <- access A.packageDescription-  maintainerOption <- access (D.maintainerOption . A.debInfo)-  uploadersOption <- access (D.uploadersOption . A.debInfo)+  maintainerOption <- access (A.debInfo . D.maintainerOption)+  uploadersOption <- access (A.debInfo . D.uploadersOption)   let cabalAuthorString = takeWhile (\ c -> c /= ',' && c /= '\n') (Cabal.author pkgDesc)       cabalMaintainerString = takeWhile (\ c -> c /= ',' && c /= '\n') (Cabal.maintainer pkgDesc)       cabalMaintainerString' = cabalAuthorString <> " <" <> cabalMaintainerString <> ">"       cabalMaintainerString'' = cabalAuthorString <> " " <> cabalMaintainerString   changelogSignature <--      do log <- access (D.changelog . A.debInfo)+      do log <- access (A.debInfo . D.changelog)          case log of            Just (ChangeLog (entry : _)) ->                case (parseMaintainer (logWho entry)) of@@ -225,31 +227,31 @@            _ -> return Nothing   case o of     True -> do-      (S.maintainer . D.control . A.debInfo) ~= Just haskellMaintainer-      (S.uploaders . D.control . A.debInfo) %= whenEmpty (maybe [] (: []) currentUser)+      (A.debInfo . D.control . S.maintainer) ~= Just haskellMaintainer+      (A.debInfo . D.control . S.uploaders) %= whenEmpty (maybe [] (: []) currentUser)     False -> do-      (S.maintainer . D.control . A.debInfo) ~?= maintainerOption-      (S.maintainer . D.control . A.debInfo) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString)-      (S.maintainer . D.control . A.debInfo) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString')-      (S.maintainer . D.control . A.debInfo) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString'')+      (A.debInfo . D.control . S.maintainer) ~?= maintainerOption+      (A.debInfo . D.control . S.maintainer) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString)+      (A.debInfo . D.control . S.maintainer) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString')+      (A.debInfo . D.control . S.maintainer) ~?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString'')       -- Sometimes the maintainer is just an email, if it matches the author's email we can use it-      (S.maintainer . D.control . A.debInfo) ~?= (case parseMaintainer cabalAuthorString of+      (A.debInfo . D.control . S.maintainer) ~?= (case parseMaintainer cabalAuthorString of                                         Right x | nameAddr_addr x == cabalMaintainerString -> Just x                                         _ -> Nothing)       -- Sometimes the maintainer is just an email, try combining it with the author's name-      (S.maintainer . D.control . A.debInfo) ~?= (case parseMaintainer cabalAuthorString of+      (A.debInfo . D.control . S.maintainer) ~?= (case parseMaintainer cabalAuthorString of                                         Right (NameAddr {nameAddr_name = Just name}) -> either (const Nothing) Just (parseMaintainer (name ++ " <" ++ cabalMaintainerString ++ ">"))                                         _ -> Nothing)-      (S.maintainer . D.control . A.debInfo) ~?= currentUser-      (S.maintainer . D.control . A.debInfo) ~?= changelogSignature-      x <- access (S.maintainer . D.control . A.debInfo)+      (A.debInfo . D.control . S.maintainer) ~?= currentUser+      (A.debInfo . D.control . S.maintainer) ~?= changelogSignature+      x <- access (A.debInfo . D.control . S.maintainer)       when (isNothing x)             (do liftIO $ putStrLn ("Unable to construct a debian maintainer, using nobody <nobody@nowhere>. Cabal maintainer strings tried:\n " ++                                   show cabalMaintainerString ++ ", " ++ show cabalMaintainerString' ++ ", " ++ show cabalMaintainerString'' ++                                   ", currentUser: " ++ show currentUser)                return ())-      (S.maintainer . D.control . A.debInfo) ~?= (either (const Nothing) Just $ parseMaintainer "nobody <nobody@nowhere>")-      (S.uploaders . D.control . A.debInfo) %= whenEmpty uploadersOption+      (A.debInfo . D.control . S.maintainer) ~?= (either (const Nothing) Just $ parseMaintainer "nobody <nobody@nowhere>")+      (A.debInfo . D.control . S.uploaders) %= whenEmpty uploadersOption  -- | If l is the empty list return d, otherwise return l. whenEmpty :: [a] -> [a] -> [a]@@ -259,10 +261,10 @@ finalizeControl :: (MonadIO m, Functor m) => CabalT m () finalizeControl =     do finalizeMaintainer-       Just src <- access (D.sourcePackageName . A.debInfo)-       (S.source . D.control . A.debInfo) ~= Just src+       Just src <- access (A.debInfo . D.sourcePackageName)+       (A.debInfo . D.control . S.source) ~= Just src        desc' <- describe-       (S.xDescription . D.control . A.debInfo) ~?= Just desc'+       (A.debInfo . D.control . S.xDescription) ~?= Just desc'        -- control %= (\ y -> y { D.source = Just src, D.maintainer = Just maint })  -- | Make sure there is a changelog entry with the version number and@@ -273,14 +275,14 @@ finalizeChangelog date =     do finalizeMaintainer        ver <- debianVersion-       src <- access (D.sourcePackageName . A.debInfo)-       Just debianMaintainer <- access (S.maintainer . D.control . A.debInfo)+       src <- access (A.debInfo . D.sourcePackageName)+       Just debianMaintainer <- access (A.debInfo . D.control . S.maintainer)        -- pkgDesc <- access T.packageDescription >>= return . maybe Nothing (either Nothing Just . parseMaintainer . Cabal.maintainer)-       cmts <- access (D.comments . A.debInfo)-       (D.changelog . A.debInfo) %= fmap (dropFutureEntries ver)+       cmts <- access (A.debInfo . D.comments)+       (A.debInfo . D.changelog) %= fmap (dropFutureEntries ver)        prog <- liftIO getProgName        let msg = pack ("Debianization generated by cabal-debian-" ++ showVersion version ++ " (" ++ show prog ++ ")")-       (D.changelog . A.debInfo) %= fixLog src ver cmts debianMaintainer msg+       (A.debInfo . D.changelog) %= fixLog src ver cmts debianMaintainer msg     where       fixLog :: Maybe SrcPkgName -> DebianVersion -> Maybe [[Text]] -> NameAddr -> Text -> Maybe ChangeLog -> Maybe ChangeLog       -- Ensure that the package name is correct in the first log entry.@@ -299,7 +301,7 @@                                  , logUrgency = "low"                                  , logComments =                                      List.unlines $ List.map (("  * " <>) . List.intercalate "\n    " . List.map unpack) (fromMaybe [[msg]] cmts)-                                 , logWho = ppDisplay maint+                                 , logWho = ppShow maint                                  , logDate = date } in           -- Creating new log entry for version           Just (ChangeLog (entry : maybe [] (\ (ChangeLog entries) -> entries) log))@@ -311,9 +313,9 @@ addExtraLibDependencies hc =     do pkgDesc <- access A.packageDescription        devName <- debianName B.Development hc-       libMap <- access (D.extraLibMap . A.debInfo)-       binNames <- List.map (getL B.package) <$> access (S.binaryPackages . D.control . A.debInfo)-       when (any (== devName) binNames) ((B.depends . B.relations . D.binaryDebDescription devName . A.debInfo) %= \ deps -> deps ++ g pkgDesc libMap)+       libMap <- access (A.debInfo . D.extraLibMap)+       binNames <- List.map (getL B.package) <$> access (A.debInfo . D.control . S.binaryPackages)+       when (any (== devName) binNames) ((A.debInfo . D.binaryDebDescription devName . B.relations . B.depends) %= \ 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)@@ -323,7 +325,7 @@ -- | Applies a few settings to official packages (unless already set) checkOfficialSettings :: (Monad m, Functor m) => CompilerFlavor -> CabalT m () checkOfficialSettings flavor =-    do o <- access (D.official . A.debInfo)+    do o <- access (A.debInfo . D.official)        when o $ case flavor of                   GHC -> officialSettings                   _ -> error $ "There is no official packaging for " ++ show flavor@@ -333,22 +335,22 @@     do pkgDesc <- access A.packageDescription        let PackageName cabal = pkgName (Cabal.package pkgDesc) -       (S.standardsVersion . D.control . A.debInfo) ~?= Just (parseStandardsVersion "3.9.5")-       (S.homepage . D.control . A.debInfo) ~?= Just ("http://hackage.haskell.org/package/" <> pack cabal)-       (D.omitProfVersionDeps . A.debInfo) ~= True-       SrcPkgName src <- access (D.sourcePackageName . A.debInfo) >>= maybe (error "officialSettings: no sourcePackageName") return+       (A.debInfo . D.control . S.standardsVersion) ~?= Just (parseStandardsVersion "3.9.5")+       (A.debInfo . D.control . S.homepage) ~?= Just ("http://hackage.haskell.org/package/" <> pack cabal)+       (A.debInfo . D.omitProfVersionDeps) ~= True+       SrcPkgName src <- access (A.debInfo . D.sourcePackageName) >>= maybe (error "officialSettings: no sourcePackageName") return -       (S.vcsFields . D.control . A.debInfo) %= Set.union (Set.fromList+       (A.debInfo . D.control . S.vcsFields) %= Set.union (Set.fromList           [ S.VCSBrowser $ "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/" <> pack src           , S.VCSDarcs  $ "http://darcs.debian.org/pkg-haskell/" <> pack src           ]) -putBuildDeps :: (MonadIO m, Functor m) => [BinPkgName] -> PackageDescription -> CabalT m ()-putBuildDeps thisPackageDebs pkgDesc =-    do deps <- debianBuildDeps pkgDesc >>= return . filterRelations thisPackageDebs-       depsIndep <- debianBuildDepsIndep pkgDesc >>= return . filterRelations thisPackageDebs-       (S.buildDepends . D.control . A.debInfo) ~= deps-       (S.buildDependsIndep . D.control . A.debInfo) ~= depsIndep+putBuildDeps :: (MonadIO m, Functor m) => (Relations -> Relations) -> PackageDescription -> CabalT m ()+putBuildDeps finalizeRelations pkgDesc =+    do deps <- debianBuildDeps pkgDesc >>= return . finalizeRelations+       depsIndep <- debianBuildDepsIndep pkgDesc >>= return . finalizeRelations+       (A.debInfo . D.control . S.buildDepends) ~= deps+       (A.debInfo . D.control . S.buildDependsIndep) ~= depsIndep  -- | Filter out any relations that mention any of the bad package names. filterRelations :: [BinPkgName] -> Relations -> Relations@@ -360,35 +362,35 @@  cabalExecBinaryPackage :: Monad m => BinPkgName -> CabalT m () cabalExecBinaryPackage b =-    do (B.packageType . D.binaryDebDescription b . A.debInfo) ~?= Just B.Exec-       (B.architecture . D.binaryDebDescription b . A.debInfo) ~?= Just Any-       (B.binarySection . D.binaryDebDescription b . A.debInfo) ~?= Just (MainSection "misc")-       (B.description . D.binaryDebDescription b . A.debInfo) ~?= Just desc -- yeah, this same line is all over the place.+    do (A.debInfo . D.binaryDebDescription b . B.packageType) ~?= Just B.Exec+       (A.debInfo . D.binaryDebDescription b . B.architecture) ~?= Just Any+       (A.debInfo . D.binaryDebDescription b . B.binarySection) ~?= Just (MainSection "misc")+       (A.debInfo . D.binaryDebDescription b . B.description) ~?= Just desc -- yeah, this same line is all over the place.        binaryPackageRelations b B.Exec     where  binaryPackageRelations :: Monad m => BinPkgName -> B.PackageType -> CabalT m () binaryPackageRelations b typ =-    do edds <- access (D.extraDevDeps . A.debInfo)-       (B.depends . B.relations . D.binaryDebDescription b . A.debInfo) %= \ rels ->+    do edds <- access (A.debInfo . D.extraDevDeps)+       (A.debInfo . D.binaryDebDescription b . B.relations . B.depends) %= \ rels ->           [anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++           [anyrel "${shlibs:Depends}" | typ `notElem` [B.Profiling, B.Documentation] ] ++           edds ++ rels-       (B.recommends . B.relations . D.binaryDebDescription b . A.debInfo) %= \ rels -> [anyrel "${haskell:Recommends}"] ++ rels-       (B.suggests . B.relations . D.binaryDebDescription b . A.debInfo) %= \ rels -> [anyrel "${haskell:Suggests}"] ++ rels-       (B.preDepends . B.relations . D.binaryDebDescription b . A.debInfo) ~= []-       (B.breaks . B.relations . D.binaryDebDescription b . A.debInfo) ~= []-       (B.conflicts . B.relations . D.binaryDebDescription b . A.debInfo) %= \ rels -> [anyrel "${haskell:Conflicts}"] ++ rels-       (B.provides . B.relations . D.binaryDebDescription b . A.debInfo) %= \ rels -> (if typ /= B.Documentation then [anyrel "${haskell:Provides}"] else []) ++ rels+       (A.debInfo . D.binaryDebDescription b . B.relations . B.recommends) %= \ rels -> [anyrel "${haskell:Recommends}"] ++ rels+       (A.debInfo . D.binaryDebDescription b . B.relations . B.suggests) %= \ rels -> [anyrel "${haskell:Suggests}"] ++ rels+       (A.debInfo . D.binaryDebDescription b . B.relations . B.preDepends) ~= []+       (A.debInfo . D.binaryDebDescription b . B.relations . B.breaks) ~= []+       (A.debInfo . D.binaryDebDescription b . B.relations . B.conflicts) %= \ rels -> [anyrel "${haskell:Conflicts}"] ++ rels+       (A.debInfo . D.binaryDebDescription b . B.relations . B.provides) %= \ rels -> (if typ /= B.Documentation then [anyrel "${haskell:Provides}"] else []) ++ rels        -- T.replaces b %= \ rels -> [anyrel "${haskell:Replaces}"] ++ rels-       (B.builtUsing . B.relations . D.binaryDebDescription b . A.debInfo) ~= []+       (A.debInfo . D.binaryDebDescription b . B.relations . B.builtUsing) ~= []  -- | Add the library paragraphs for a particular compiler flavor. librarySpecs :: (Monad m, Functor m) => PackageDescription -> CompilerFlavor -> CabalT m () librarySpecs pkgDesc hc =     do let dev = isJust (Cabal.library pkgDesc)-       doc <- get >>= return . not . getL (D.noDocumentationLibrary . A.debInfo)-       prof <- get >>= return . not . getL (D.noProfilingLibrary . A.debInfo)+       doc <- get >>= return . not . getL (A.debInfo . D.noDocumentationLibrary)+       prof <- get >>= return . not . getL (A.debInfo . D.noProfilingLibrary)        when dev (librarySpec Any B.Development hc)        when (dev && prof && hc == GHC) (librarySpec Any B.Profiling hc)        when (dev && doc) (docSpecsParagraph hc)@@ -397,20 +399,20 @@ docSpecsParagraph hc =     do b <- debianName B.Documentation hc        binaryPackageRelations b B.Documentation-       (B.packageType . D.binaryDebDescription b . A.debInfo) ~?= Just B.Documentation-       (B.packageType . D.binaryDebDescription b . A.debInfo) ~?= Just B.Documentation-       (B.architecture . D.binaryDebDescription b . A.debInfo) ~= Just All-       (B.binarySection . D.binaryDebDescription b . A.debInfo) ~?= Just (MainSection "doc")-       (B.description . D.binaryDebDescription b . A.debInfo) ~?= Just desc+       (A.debInfo . D.binaryDebDescription b . B.packageType) ~?= Just B.Documentation+       (A.debInfo . D.binaryDebDescription b . B.packageType) ~?= Just B.Documentation+       (A.debInfo . D.binaryDebDescription b . B.architecture) ~= Just All+       (A.debInfo . D.binaryDebDescription b . B.binarySection) ~?= Just (MainSection "doc")+       (A.debInfo . D.binaryDebDescription b . B.description) ~?= Just desc  librarySpec :: (Monad m, Functor m) => PackageArchitectures -> B.PackageType -> CompilerFlavor -> CabalT m () librarySpec arch typ hc =     do b <- debianName typ hc        binaryPackageRelations b typ-       (B.packageType . D.binaryDebDescription b . A.debInfo) ~?= Just typ-       (B.packageType . D.binaryDebDescription b . A.debInfo) ~?= Just typ-       (B.architecture . D.binaryDebDescription b . A.debInfo) ~?= Just arch-       (B.description . D.binaryDebDescription b . A.debInfo) ~?= Just desc+       (A.debInfo . D.binaryDebDescription b . B.packageType) ~?= Just typ+       (A.debInfo . D.binaryDebDescription b . B.packageType) ~?= Just typ+       (A.debInfo . D.binaryDebDescription b . B.architecture) ~?= Just arch+       (A.debInfo . D.binaryDebDescription b . B.description) ~?= Just desc  -- | This is the standard value for the Description field of a binary -- package control file stanza.@@ -436,28 +438,28 @@                                            D.Install b from _ -> Map.insertWith Set.union b (singleton from) r                                            D.InstallTo b from _ -> Map.insertWith Set.union b (singleton from) r                                            D.InstallData b from _ -> Map.insertWith Set.union b (singleton from) r-                                           _ -> r) mempty <$> access (D.atomSet . A.debInfo) :: CabalT m (Map BinPkgName (Set FilePath))+                                           _ -> r) mempty <$> access (A.debInfo . D.atomSet) :: CabalT m (Map BinPkgName (Set FilePath))        installedExecMap <- Set.fold (\ x r ->                                          case x of                                            D.InstallCabalExec b name _ -> Map.insertWith Set.union b (singleton name) r                                            D.InstallCabalExecTo b name _ -> Map.insertWith Set.union b (singleton name) r-                                           _ -> r) mempty <$> access (D.atomSet . A.debInfo) :: CabalT m (Map BinPkgName (Set String))+                                           _ -> r) mempty <$> access (A.debInfo . D.atomSet) :: CabalT m (Map BinPkgName (Set String))         -- The names of cabal executables that go into eponymous debs-       insExecPkg <- access (D.executable . A.debInfo) >>= return . Set.map ename . Set.fromList . elems+       insExecPkg <- access (A.debInfo . D.executable) >>= return . Set.map ename . Set.fromList . elems         let installedData = Set.map (\ a -> (a, a)) $ Set.unions (Map.elems installedDataMap)            installedExec = Set.unions (Map.elems installedExecMap) -       let prefixPath = Cabal.dataDir pkgDesc+       prefixPath <- dataTop        let dataFilePaths = Set.fromList (zip (List.map (prefixPath </>) (Cabal.dataFiles pkgDesc)) (Cabal.dataFiles pkgDesc)) :: Set (FilePath, FilePath)            execFilePaths = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc))) :: Set FilePath        let availableData = Set.union installedData dataFilePaths            availableExec = Set.union installedExec execFilePaths -       access (D.utilsPackageNameBase . A.debInfo) >>= \ name ->+       access (A.debInfo . D.utilsPackageNameBase) >>= \ name ->            case name of-             Nothing -> debianName B.Utilities hc >>= \ (BinPkgName name') -> (D.utilsPackageNameBase . A.debInfo) ~= Just name'+             Nothing -> debianName B.Utilities hc >>= \ (BinPkgName name') -> (A.debInfo . D.utilsPackageNameBase) ~= Just name'              _ -> return ()        b <- debianName B.Utilities hc @@ -473,15 +475,15 @@            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)) $ do-         (B.description . D.binaryDebDescription b . A.debInfo) ~?= Just desc+         (A.debInfo . D.binaryDebDescription b . B.description) ~?= Just desc          -- This is really for all binary debs except the libraries - I'm not sure why-         (D.rulesFragments . A.debInfo)+= (pack ("build" </> ppDisplay b ++ ":: build-ghc-stamp\n"))-         (B.architecture . D.binaryDebDescription b . A.debInfo) ~?= Just (if Set.null utilsExec then All else Any)-         (B.binarySection . D.binaryDebDescription b . A.debInfo) ~?= Just (MainSection "misc")+         (A.debInfo . D.rulesFragments)+= (pack ("build" </> ppShow b ++ ":: build-ghc-stamp\n"))+         (A.debInfo . D.binaryDebDescription b . B.architecture) ~?= Just (if Set.null utilsExec then All else Any)+         (A.debInfo . D.binaryDebDescription b . B.binarySection) ~?= Just (MainSection "misc")          binaryPackageRelations b B.Utilities        -- Add the unassigned files to the utils packages-       Set.mapM_ (\ (foo, bar) -> (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing-       Set.mapM_ (\ name -> (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallCabalExec b name "usr/bin")) utilsExecMissing+       Set.mapM_ (\ (foo, bar) -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing+       Set.mapM_ (\ name -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec b name "usr/bin")) utilsExecMissing     where       ename i =           case D.sourceDir i of@@ -490,23 +492,23 @@  expandAtoms :: MonadIO m => CabalT m () expandAtoms =-    do hc <- access (compilerFlavor . D.flags . A.debInfo)+    do hc <- access (A.debInfo . D.flags . compilerFlavor)        case hc of-         GHC -> (cabalFlagAssignments . D.flags . A.debInfo) %= (Set.union (Set.fromList (flagList "--ghc")))+         GHC -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghc"))) #if MIN_VERSION_Cabal(1,22,0)-         GHCJS -> (cabalFlagAssignments . D.flags . A.debInfo) %= (Set.union (Set.fromList (flagList "--ghcjs")))+         GHCJS -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghcjs"))) #endif-       builddir <- access (D.buildDir . A.debInfo) >>= return . fromMaybe (case hc of+       builddir <- access (A.debInfo . D.buildDir) >>= return . fromMaybe (case hc of                                                                GHC -> "dist-ghc/build" #if MIN_VERSION_Cabal(1,22,0)                                                                GHCJS -> "dist-ghcjs/build" #endif                                                                _ -> error $ "Unexpected compiler: " ++ show hc)-       dDir <- dataDir+       dDest <- dataDest        expandApacheSites        expandInstallCabalExecs builddir        expandInstallCabalExecTo builddir-       expandInstallData dDir+       expandInstallData dDest        expandInstallTo        expandFile        expandWebsite@@ -516,119 +518,119 @@     where       expandApacheSites :: Monad m => CabalT m ()       expandApacheSites =-          do mp <- get >>= return . getL (D.apacheSite . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.apacheSite)              List.mapM_ expandApacheSite (Map.toList mp)           where             expandApacheSite (b, (dom, log, text)) =-                do (D.atomSet . A.debInfo) %= (Set.insert $ D.Link b ("/etc/apache2/sites-available/" ++ dom) ("/etc/apache2/sites-enabled/" ++ dom))-                   (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallDir b log)-                   (D.atomSet . A.debInfo) %= (Set.insert $ D.File b ("/etc/apache2/sites-available" </> dom) text)+                do (A.debInfo . D.atomSet) %= (Set.insert $ D.Link b ("/etc/apache2/sites-available/" ++ dom) ("/etc/apache2/sites-enabled/" ++ dom))+                   (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallDir b log)+                   (A.debInfo . D.atomSet) %= (Set.insert $ D.File b ("/etc/apache2/sites-available" </> dom) text)        -- Turn A.InstallCabalExec into A.Install       expandInstallCabalExecs :: Monad m => FilePath -> CabalT m ()       expandInstallCabalExecs builddir = do-        hc <- access (compilerFlavor . D.flags . A.debInfo)-        access (D.atomSet . A.debInfo) >>= Set.mapM_ (doAtom hc)+        hc <- access (A.debInfo . D.flags . compilerFlavor)+        access (A.debInfo . D.atomSet) >>= Set.mapM_ (doAtom hc)           where             doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m ()-            doAtom GHC (D.InstallCabalExec b name dest) = (D.atomSet . A.debInfo) %= (Set.insert $ D.Install b (builddir </> name </> name) dest)+            doAtom GHC (D.InstallCabalExec b name dest) = (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b (builddir </> name </> name) dest) #if MIN_VERSION_Cabal(1,22,0)             -- A GHCJS executable is a directory with files, copy them             -- all into place.             doAtom GHCJS (D.InstallCabalExec b name dest) =-                (D.rulesFragments . A.debInfo) +=+                (A.debInfo . D.rulesFragments) +=                      (Text.unlines-                        [ pack ("binary-fixup" </> ppDisplay b) <> "::"+                        [ pack ("binary-fixup" </> ppShow b) <> "::"                         , pack ("\t(cd " <> builddir </> name <> " && find " <> name <.> "jsexe" <> " -type f) |\\\n" <>-                                       "\t  while read i; do install -Dp " <> builddir </> name </> "$$i debian" </> ppDisplay b </> makeRelative "/" dest </> "$$i; done\n") ])+                                       "\t  while read i; do install -Dp " <> builddir </> name </> "$$i debian" </> ppShow b </> makeRelative "/" dest </> "$$i; done\n") ]) #endif             doAtom _ _ = return ()        -- Turn A.InstallCabalExecTo into a make rule       expandInstallCabalExecTo :: Monad m => FilePath -> CabalT m ()       expandInstallCabalExecTo builddir = do-        hc <- access (compilerFlavor . D.flags . A.debInfo)-        access (D.atomSet . A.debInfo) >>= Set.mapM_ (doAtom hc)+        hc <- access (A.debInfo . D.flags . compilerFlavor)+        access (A.debInfo . D.atomSet) >>= Set.mapM_ (doAtom hc)           where             doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m ()             doAtom GHC (D.InstallCabalExecTo b name dest) =-                (D.rulesFragments . A.debInfo) +=+                (A.debInfo . D.rulesFragments) +=                                      (Text.unlines-                                       [ pack ("binary-fixup" </> ppDisplay b) <> "::"+                                       [ pack ("binary-fixup" </> ppShow b) <> "::"                                        , "\tinstall -Dps " <> pack (builddir </> name </> name) <> " "-                                                           <> pack ("debian" </> ppDisplay b </> makeRelative "/" dest) ])+                                                           <> pack ("debian" </> ppShow b </> makeRelative "/" dest) ])             doAtom hc (D.InstallCabalExecTo b name dest) = error $ "expandInstallCabalExecTo " ++ show hc ++ " " ++ show (D.InstallCabalExecTo b name dest)             doAtom _ _ = return ()        -- Turn A.InstallData into either an Install or an InstallTo       expandInstallData :: Monad m => FilePath -> CabalT m ()-      expandInstallData dDir =-          access (D.atomSet . A.debInfo) >>= List.mapM_ doAtom . Set.toList+      expandInstallData dDest =+          access (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList           where             doAtom :: Monad m => D.Atom -> CabalT m ()             doAtom (D.InstallData b from dest) =                 if takeFileName from == takeFileName dest-                then (D.atomSet . A.debInfo) %= (Set.insert $ D.Install b from (dDir </> makeRelative "/" (takeDirectory dest)))-                else (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallTo b from (dDir </> makeRelative "/" dest))+                then (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b from (dDest </> makeRelative "/" (takeDirectory dest)))+                else (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallTo b from (dDest </> makeRelative "/" dest))             doAtom _ = return ()        -- Turn A.InstallTo into a make rule       expandInstallTo :: Monad m => CabalT m ()       expandInstallTo =-          access (D.atomSet . A.debInfo) >>= List.mapM_ doAtom . Set.toList+          access (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList           where             doAtom :: Monad m => D.Atom -> CabalT m ()             doAtom (D.InstallTo b from dest) =-                (D.rulesFragments . A.debInfo) +=-                                    (Text.unlines [ pack ("binary-fixup" </> ppDisplay b) <> "::"-                                                  , "\tinstall -Dp " <> pack from <> " " <> pack ("debian" </> ppDisplay b </> makeRelative "/" dest) ])+                (A.debInfo . D.rulesFragments) +=+                                    (Text.unlines [ pack ("binary-fixup" </> ppShow b) <> "::"+                                                  , "\tinstall -Dp " <> pack from <> " " <> pack ("debian" </> ppShow b </> makeRelative "/" dest) ])             doAtom _ = return ()        -- Turn A.File into an intermediateFile and an A.Install       expandFile :: Monad m => CabalT m ()       expandFile =-          access (D.atomSet . A.debInfo) >>= List.mapM_ doAtom . Set.toList+          access (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList           where             doAtom :: Monad m => D.Atom -> CabalT m ()             doAtom (D.File b path text) =                 do let (destDir', destName') = splitFileName path                        tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack text)))                        tmpPath = tmpDir </> destName'-                   (D.intermediateFiles . A.debInfo) += (tmpPath, text)-                   (D.atomSet . A.debInfo) %= (Set.insert $ D.Install b tmpPath destDir')+                   (A.debInfo . D.intermediateFiles) += (tmpPath, text)+                   (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b tmpPath destDir')             doAtom _ = return ()        expandWebsite :: Monad m => CabalT m ()       expandWebsite =-          do mp <- get >>= return . getL (D.website . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.website)              List.mapM_ (\ (b, site) -> modify (siteAtoms b site)) (Map.toList mp)        expandServer :: Monad m => CabalT m ()       expandServer =-          do mp <- get >>= return . getL (D.serverInfo . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.serverInfo)              List.mapM_ (\ (b, x) -> modify (serverAtoms b x False)) (Map.toList mp)        expandBackups :: Monad m => CabalT m ()       expandBackups =-          do mp <- get >>= return . getL (D.backups . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.backups)              List.mapM_ (\ (b, name) -> modify (backupAtoms b name)) (Map.toList mp)        expandExecutable :: Monad m => CabalT m ()       expandExecutable =-          do mp <- get >>= return . getL (D.executable . A.debInfo)+          do mp <- get >>= return . getL (A.debInfo . D.executable)              List.mapM_ (\ (b, f) -> modify (execAtoms b f)) (Map.toList mp)  -- | Add the normal default values to the rules files. finalizeRules :: (Monad m, Functor m) => CabalT m () finalizeRules =     do DebBase b <- debianNameBase-       compiler <- access (compilerFlavor . D.flags . A.debInfo)-       (D.rulesHead . A.debInfo) ~?= Just "#!/usr/bin/make -f"-       (D.rulesSettings . A.debInfo) %= (++ ["DEB_CABAL_PACKAGE = " <> pack b])-       (D.rulesSettings . A.debInfo) %= (++ (["DEB_DEFAULT_COMPILER = " <> pack (List.map toLower (show compiler))]))-       flags <- (flagString . Set.toList) <$> access (cabalFlagAssignments . D.flags . A.debInfo)-       unless (List.null flags) ((D.rulesSettings . A.debInfo) %= (++ ["DEB_SETUP_GHC6_CONFIGURE_ARGS = " <> pack flags]))-       (D.rulesIncludes . A.debInfo) %= (++ ["include /usr/share/cdbs/1/rules/debhelper.mk",+       compiler <- access (A.debInfo . D.flags . compilerFlavor)+       (A.debInfo . D.rulesHead) ~?= Just "#!/usr/bin/make -f"+       (A.debInfo . D.rulesSettings) %= (++ ["DEB_CABAL_PACKAGE = " <> pack b])+       (A.debInfo . D.rulesSettings) %= (++ (["DEB_DEFAULT_COMPILER = " <> pack (List.map toLower (show compiler))]))+       flags <- (flagString . Set.toList) <$> access (A.debInfo . D.flags . cabalFlagAssignments)+       unless (List.null flags) ((A.debInfo . D.rulesSettings) %= (++ ["DEB_SETUP_GHC6_CONFIGURE_ARGS = " <> pack flags]))+       (A.debInfo . D.rulesIncludes) %= (++ ["include /usr/share/cdbs/1/rules/debhelper.mk",                                              "include /usr/share/cdbs/1/class/hlibrary.mk"])  data Dependency_

@@ -18,9 +18,10 @@     , execAtoms     ) where +import OldLens (access, modL)+ import Control.Category ((.)) import Data.Char (isSpace)-import Data.Lens.Lazy (access, modL) import Data.List as List (dropWhileEnd, intercalate, intersperse, map) import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe)@@ -34,7 +35,7 @@ import qualified Debian.Debianize.BinaryDebDescription as B import Debian.Orphans () import Debian.Policy (apacheAccessLog, apacheErrorLog, apacheLogDirectory, databaseDirectory, serverAccessLog, serverAppLog)-import Debian.Pretty (ppDisplay, ppDisplay')+import Debian.Pretty (ppShow, ppText) import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel)) import Distribution.Package (PackageName(PackageName)) import Distribution.PackageDescription as Cabal (PackageDescription(package, synopsis, description))@@ -72,25 +73,25 @@       equals (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (=$${Version})' " <>  display' installed <> " >> debian/" <> name <> ".substvars"       newer  (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (>>$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars"       name = display' p-      display' = ppDisplay'+      display' = ppText  -- | Add a debian binary package to the debianization containing a cabal executable file. doExecutable :: Monad m => BinPkgName -> D.InstallFile -> CabalT m ()-doExecutable p f = (D.executable . A.debInfo) ++= (p, f)+doExecutable p f = (A.debInfo . D.executable) ++= (p, f)  -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a server. doServer :: Monad m => BinPkgName -> D.Server -> CabalT m ()-doServer p s = (D.serverInfo . A.debInfo) ++= (p, s)+doServer p s = (A.debInfo . D.serverInfo) ++= (p, s)  -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a web site. doWebsite :: Monad m => BinPkgName -> D.Site -> CabalT m ()-doWebsite p w = (D.website . A.debInfo) ++= (p, w)+doWebsite p w = (A.debInfo . D.website) ++= (p, w)  -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a backup script. doBackups :: Monad m => BinPkgName -> String -> CabalT m () doBackups bin s =-    do (D.backups . A.debInfo) ++= (bin, s)-       (B.depends . B.relations . D.binaryDebDescription bin . A.debInfo) %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]])+    do (A.debInfo . D.backups) ++= (bin, s)+       (A.debInfo . D.binaryDebDescription bin . B.relations . B.depends) %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]])        -- depends +++= (bin, Rel (BinPkgName "anacron") Nothing Nothing)  describe :: Monad m => CabalT m Text@@ -142,7 +143,7 @@       -- If we have a one line description and no synopsis, use       -- the description as the synopsis.       synop' = if null synop && length desc /= 1-               then "WARNING: No synopsis available for package " ++ ppDisplay (package p)+               then "WARNING: No synopsis available for package " ++ ppShow (package p)                else synop       synop :: String       -- I don't know why (unwords . words) was applied here.  Maybe I'll find out when@@ -171,11 +172,11 @@ siteAtoms :: BinPkgName -> D.Site -> CabalInfo -> CabalInfo siteAtoms b site =     execCabalM-      (do (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallDir b "/etc/apache2/sites-available")-          (D.atomSet . A.debInfo) %= (Set.insert $ D.Link b ("/etc/apache2/sites-available/" ++ D.domain site) ("/etc/apache2/sites-enabled/" ++ D.domain site))-          (D.atomSet . A.debInfo) %= (Set.insert $ D.File b ("/etc/apache2/sites-available" </> D.domain site) apacheConfig)-          (D.atomSet . A.debInfo) %= (Set.insert $ D.InstallDir b (apacheLogDirectory b))-          (D.logrotateStanza . A.debInfo) +++=+      (do (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallDir b "/etc/apache2/sites-available")+          (A.debInfo . D.atomSet) %= (Set.insert $ D.Link b ("/etc/apache2/sites-available/" ++ D.domain site) ("/etc/apache2/sites-enabled/" ++ D.domain site))+          (A.debInfo . D.atomSet) %= (Set.insert $ D.File b ("/etc/apache2/sites-available" </> D.domain site) apacheConfig)+          (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallDir b (apacheLogDirectory b))+          (A.debInfo . D.logrotateStanza) +++=                               (b, singleton                                    (Text.unlines $ [ pack (apacheAccessLog b) <> " {"                                                    , "  copytruncate" -- hslogger doesn't notice when the log is rotated, maybe this will help@@ -184,7 +185,7 @@                                                    , "  compress"                                                    , "  missingok"                                                    , "}"]))-          (D.logrotateStanza . A.debInfo) +++=+          (A.debInfo . D.logrotateStanza) +++=                               (b, singleton                                    (Text.unlines $ [ pack (apacheErrorLog b) <> " {"                                                    , "  copytruncate"@@ -235,8 +236,8 @@  serverAtoms :: BinPkgName -> D.Server -> Bool -> CabalInfo -> CabalInfo serverAtoms b server' isSite =-    modL (D.postInst . A.debInfo) (insertWith (\ old new -> if old /= new then error ("serverAtoms: " ++ show old ++ " -> " ++ show new) else old) b debianPostinst) .-    modL (D.installInit . A.debInfo) (Map.insertWith (\ old new -> if old /= new then error ("serverAtoms: " ++ show old ++ " -> " ++ show new) else old) b debianInit) .+    modL (A.debInfo . D.postInst) (insertWith (\ old new -> if old /= new then error ("serverAtoms: " ++ show old ++ " -> " ++ show new) else old) b debianPostinst) .+    modL (A.debInfo . D.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@@ -300,13 +301,13 @@ -- in debianFiles. serverLogrotate' :: BinPkgName -> CabalInfo -> CabalInfo serverLogrotate' b =-    modL (D.logrotateStanza . A.debInfo) (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {"+    modL (A.debInfo . D.logrotateStanza) (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {"                                  , "  weekly"                                  , "  rotate 5"                                  , "  compress"                                  , "  missingok"                                  , "}" ]))) .-    modL (D.logrotateStanza . A.debInfo) (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {"+    modL (A.debInfo . D.logrotateStanza) (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {"                                  , "  weekly"                                  , "  rotate 5"                                  , "  compress"@@ -315,7 +316,7 @@  backupAtoms :: BinPkgName -> String -> CabalInfo -> CabalInfo backupAtoms b name =-    modL (D.postInst . A.debInfo) (insertWith (\ old new -> if old /= new then error $ "backupAtoms: " ++ show old ++ " -> " ++ show new else old) b+    modL (A.debInfo . D.postInst) (insertWith (\ old new -> if old /= new then error $ "backupAtoms: " ++ show old ++ " -> " ++ show new else old) b                  (Text.unlines $                   [ "#!/bin/sh"                   , ""@@ -331,7 +332,7 @@  execAtoms :: BinPkgName -> D.InstallFile -> CabalInfo -> CabalInfo execAtoms b ifile r =-    modL (D.rulesFragments . A.debInfo) (Set.insert (pack ("build" </> ppDisplay b ++ ":: build-ghc-stamp\n"))) .+    modL (A.debInfo . D.rulesFragments) (Set.insert (pack ("build" </> ppShow b ++ ":: build-ghc-stamp\n"))) .     fileAtoms b ifile $     r @@ -342,9 +343,9 @@ fileAtoms' :: BinPkgName -> Maybe FilePath -> String -> Maybe FilePath -> String -> CabalInfo -> CabalInfo fileAtoms' b sourceDir' execName' destDir' destName' r =     case (sourceDir', execName' == destName') of-      (Nothing, True) -> execCabalM ((D.atomSet . A.debInfo) %= (Set.insert $ D.InstallCabalExec b execName' d)) r-      (Just s, True) -> execCabalM ((D.atomSet . A.debInfo) %= (Set.insert $ D.Install b (s </> execName') d)) r-      (Nothing, False) -> execCabalM ((D.atomSet . A.debInfo) %= (Set.insert $ D.InstallCabalExecTo b execName' (d </> destName'))) r-      (Just s, False) -> execCabalM ((D.atomSet . A.debInfo) %= (Set.insert $ D.InstallTo b (s </> execName') (d </> destName'))) r+      (Nothing, True) -> execCabalM ((A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec b execName' d)) r+      (Just s, True) -> execCabalM ((A.debInfo . D.atomSet) %= (Set.insert $ D.Install b (s </> execName') d)) r+      (Nothing, False) -> execCabalM ((A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExecTo b execName' (d </> destName'))) r+      (Just s, False) -> execCabalM ((A.debInfo . D.atomSet) %= (Set.insert $ D.InstallTo b (s </> execName') (d </> destName'))) r     where       d = fromMaybe "usr/bin" destDir'

@@ -4,10 +4,11 @@     ( inputCabalization     ) where +import OldLens (getL)+ import Control.Category ((.)) import Control.Exception (bracket) import Control.Monad (when)-import Data.Lens.Common (getL) import Data.Set as Set (Set, toList) import Debian.Debianize.BasicInfo (Flags, buildEnv, dependOS, verbosity, compilerFlavor, cabalFlagAssignments) import Debian.Debianize.Prelude (intToVerbosity')

@@ -5,15 +5,17 @@     ( inputDebianization     , inputDebianizationFile     , inputChangeLog-    , dataDir+    , dataDest+    , dataTop     ) where +import OldLens (access, modL, setL)+ import Control.Category ((.)) import Control.Monad (filterM) import Control.Monad.State (put) import Control.Monad.Trans (liftIO, MonadIO) import Data.Char (isSpace)-import Data.Lens.Lazy (access, modL, setL) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Set as Set (fromList, insert, singleton)@@ -134,15 +136,15 @@       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 ("Depends", x)) (desc, unrecognized) = (setL (B.relations . B.depends) (rels x) desc, unrecognized)+      readField (Field ("Recommends", x)) (desc, unrecognized) = (setL (B.relations . B.recommends) (rels x) desc, unrecognized)+      readField (Field ("Suggests", x)) (desc, unrecognized) = (setL (B.relations . B.suggests) (rels x) desc, unrecognized)+      readField (Field ("Pre-Depends", x)) (desc, unrecognized) = (setL (B.relations . B.preDepends) (rels x) desc, unrecognized)+      readField (Field ("Breaks", x)) (desc, unrecognized) = (setL (B.relations . B.breaks) (rels x) desc, unrecognized)+      readField (Field ("Conflicts", x)) (desc, unrecognized) = (setL (B.relations . B.conflicts) (rels x) desc, unrecognized)+      readField (Field ("Provides", x)) (desc, unrecognized) = (setL (B.relations . B.provides) (rels x) desc, unrecognized)+      readField (Field ("Replaces", x)) (desc, unrecognized) = (setL (B.relations . B.replaces) (rels x) desc, unrecognized)+      readField (Field ("Built-Using", x)) (desc, unrecognized) = (setL (B.relations . B.builtUsing) (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) @@ -249,13 +251,20 @@ -- chroot "/" task = task -- chroot root task = useEnv root (return . force) task --- | 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 :: MonadIO m => CabalT m FilePath-dataDir = do+-- | Where to put the installed data files.  Computes the destination+-- directory 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.+dataDest :: MonadIO m => CabalT m FilePath+dataDest = do   d <- access packageDescription+  return $ "usr/share" </> ((\ (PackageName x) -> x) $ pkgName $ Cabal.package d)++-- | Where to look for the data-files+dataTop :: MonadIO m => CabalT m FilePath+dataTop = do+  d <- access packageDescription   return $ case Cabal.dataDir d of-             [] -> "usr/share" </> ((\ (PackageName x) -> x) $ pkgName $ Cabal.package d)+             "" -> "."              x -> x

@@ -21,8 +21,9 @@     , liftCabal     ) where +import OldLens (focus)+ import Control.Monad.State (evalState, evalStateT, execState, execStateT, runState, State, StateT(runStateT))-import Data.Lens.Lazy (focus) import Debian.Debianize.DebInfo (DebInfo) import Debian.Debianize.CabalInfo (CabalInfo, debInfo) import Debian.Orphans ()

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, RankNTypes #-} module Debian.Debianize.Options     ( options     , compileArgs@@ -8,11 +8,12 @@     , withEnvironmentArgs     ) where +import OldLens (focus, Lens)+ import Control.Category ((.)) import Control.Monad.State (StateT) import Control.Monad.Trans (liftIO, MonadIO) import Data.Char (isDigit, ord)-import Data.Lens.Lazy (focus, Lens) import Debian.Debianize.BasicInfo (flagOptions, Flags) import Debian.Debianize.DebInfo (DebInfo, flags, binaryDebDescription) import qualified  Debian.Debianize.DebInfo as D@@ -42,10 +43,9 @@ compileArgs args =     case getOpt' RequireOrder options args of       (os, [], [], []) -> sequence_ os-      (_, non, unk, errs) -> error ("Arguments: " ++ show args ++-                                    "\n Errors: " ++ show errs ++-                                    "\n  Unrecognized: " ++ show unk ++-                                    "\n  Non-Options: " ++ show non)+      (_, non, unk, errs) -> error ("Errors: " ++ show errs +++                                    ", Unrecognized: " ++ show unk +++                                    ", Non-Options: " ++ show non)  -- | Get a list of arguments from the CABALDEBIAN environment variable -- and apply them to the monadic state.@@ -75,42 +75,42 @@     [ 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 "" ["default-package"] (ReqArg (\ name -> (D.utilsPackageNameBase . A.debInfo) ~= Just name) "NAME")+      Option "" ["default-package"] (ReqArg (\ name -> (A.debInfo . D.utilsPackageNameBase) ~= Just name) "NAME")              (unlines [ "Set the name of the catch-all package that receives all the files not included in a library package or "                       , " some other executable package.  By default this is 'haskell-packagename-utils'."]),-      Option "" ["disable-haddock"] (NoArg ((D.noDocumentationLibrary . A.debInfo) ~= True))+      Option "" ["disable-haddock"] (NoArg ((A.debInfo . D.noDocumentationLibrary) ~= 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 -> (D.missingDependencies . A.debInfo) += (BinPkgName name)) "DEB")+      Option "" ["missing-dependency"] (ReqArg (\ name -> (A.debInfo . D.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 "" ["debian-name-base"] (ReqArg (\ name -> (D.overrideDebianNameBase . A.debInfo) ~= (Just (DebBase name))) "NAME")+      Option "" ["debian-name-base"] (ReqArg (\ name -> (A.debInfo . D.overrideDebianNameBase) ~= (Just (DebBase name))) "NAME")              (unlines [ "Use this name for the base of the debian binary packages - the string between 'libghc-'"                       , " and '-dev'.  Normally this is derived from the hackage package name."]),-      Option "" ["source-package-name"] (ReqArg (\ name -> (D.sourcePackageName . A.debInfo) ~= (Just (SrcPkgName name))) "NAME")+      Option "" ["source-package-name"] (ReqArg (\ name -> (A.debInfo . D.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 "" ["source-section"] (ReqArg (\ name -> (S.section . D.control . A.debInfo) ~= Just (read name)) "NAME")+      Option "" ["source-section"] (ReqArg (\ name -> (A.debInfo . D.control . S.section) ~= Just (read name)) "NAME")              "Set the Section: field of the Debian source package.",-      Option "" ["disable-library-profiling"] (NoArg ((D.noProfilingLibrary . A.debInfo) ~= True))+      Option "" ["disable-library-profiling"] (NoArg ((A.debInfo . D.noProfilingLibrary) ~= 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 (\ s -> either (error ("Invalid maintainer string: " ++ show s)) (((D.maintainerOption . A.debInfo) ~=) . Just) (parseMaintainer s)) "Maintainer Name <email addr>")+      Option "" ["maintainer"] (ReqArg (\ s -> either (error ("Invalid maintainer string: " ++ show s)) (((A.debInfo . D.maintainerOption) ~=) . Just) (parseMaintainer s)) "Maintainer Name <email addr>")              (unlines [ "Supply a value for the Maintainer field.  Final value is computed from several inputs."]),-      Option "" ["uploader"] (ReqArg (\ s -> either (error ("Invalid uploader string: " ++ show s)) (\ x -> (D.uploadersOption . A.debInfo) %= (\ l -> l ++ [x])) (parseMaintainer s)) "Uploader Name <email addr>")+      Option "" ["uploader"] (ReqArg (\ s -> either (error ("Invalid uploader string: " ++ show s)) (\ x -> (A.debInfo . D.uploadersOption) %= (\ l -> l ++ [x])) (parseMaintainer s)) "Uploader Name <email addr>")              (unlines [ "Add one entry to the uploader list"]),-      Option "" ["standards-version"] (ReqArg (\ sv -> (S.standardsVersion . D.control . A.debInfo) ~= Just (parseStandardsVersion sv)) "VERSION")+      Option "" ["standards-version"] (ReqArg (\ sv -> (A.debInfo . D.control . S.standardsVersion) ~= Just (parseStandardsVersion sv)) "VERSION")              "Claim compatibility to this version of the Debian policy (i.e. the value of the Standards-Version field)",       Option "" ["build-dep"]                  (ReqArg (\ name ->                               case parseRelations name of                                 Left err -> error ("cabal-debian option --build-dep " ++ show name ++ ": " ++ show err)-                                Right rss -> (S.buildDepends . D.control . A.debInfo) %= (++ rss)) "Debian package relations")+                                Right rss -> (A.debInfo . D.control . S.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"@@ -119,42 +119,42 @@                  (ReqArg (\ name ->                               case parseRelations name of                                 Left err -> error ("cabal-debian option --build-dep-indep " ++ show name ++ ": " ++ show err)-                                Right rss -> (S.buildDependsIndep . D.control . A.debInfo) %= (++ rss)) "Debian binary package name")+                                Right rss -> (A.debInfo . D.control . S.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 -> (D.extraDevDeps . A.debInfo) %= (++ [[Rel (BinPkgName name) Nothing Nothing]])) "Debian binary package name")+      Option "" ["dev-dep"] (ReqArg (\ name -> (A.debInfo . D.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 (addDep (\b -> B.depends . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.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 (addDep (\b -> B.conflicts . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.conflicts)) "deb:deb,deb:deb,...")              "Like --depends, modifies the Conflicts field.",       Option "" ["replaces"]-             (ReqArg (addDep (\b -> B.replaces . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.replaces)) "deb:deb,deb:deb,...")              "Like --depends, modifies the Replaces field.",       Option "" ["provides"]-             (ReqArg (addDep (\b -> B.provides . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.provides)) "deb:deb,deb:deb,...")              "Like --depends, modifies the Provides field.",       Option "" ["recommends"]-             (ReqArg (addDep (\b -> B.recommends . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.recommends)) "deb:deb,deb:deb,...")              "Like --depends, modifies the Recommends field.",       Option "" ["suggests"]-             (ReqArg (addDep (\b -> B.suggests . B.relations . binaryDebDescription b)) "deb:deb,deb:deb,...")+             (ReqArg (addDep (\b -> binaryDebDescription b . B.relations . B.suggests)) "deb:deb,deb:deb,...")              "Like --depends, modifies the Suggests field.",       Option "" ["map-dep"] (ReqArg (\ pair -> case break (== '=') pair of-                                                 (cab, (_ : deb)) -> (D.extraLibMap . A.debInfo) +++= (cab, rels deb)+                                                 (cab, (_ : deb)) -> (A.debInfo . D.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 -> (D.debVersion . A.debInfo) ~= Just (parseDebianVersion version)) "VERSION")+      Option "" ["deb-version"] (ReqArg (\ version -> (A.debInfo . D.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 (\ rev -> (D.revision . A.debInfo) ~= Just rev) "REVISION")+      Option "" ["revision"] (ReqArg (\ rev -> (A.debInfo . D.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 -> case break (== '=') pair of@@ -163,41 +163,44 @@                                   _ -> 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 -> case break (== '=') s of-                                               (cab, (_ : deb)) -> (D.execMap . A.debInfo) ++= (cab, rels deb)+                                               (cab, (_ : deb)) -> (A.debInfo . D.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-prof-version-deps"] (NoArg ((D.omitProfVersionDeps . A.debInfo) ~= True))+      Option "" ["omit-prof-version-deps"] (NoArg ((A.debInfo . D.omitProfVersionDeps) ~= True))              "Do not put the version dependencies on the prof packages that we put on the dev packages.",-      Option "" ["omit-lt-deps"] (NoArg ((D.omitLTDeps . A.debInfo) ~= True))+      Option "" ["omit-lt-deps"] (NoArg ((A.debInfo . D.omitLTDeps) ~= 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 ((D.sourceFormat . A.debInfo) ~= Just Quilt3))+      Option "" ["quilt"] (NoArg ((A.debInfo . D.sourceFormat) ~= Just Quilt3))              "The package has an upstream tarball, write '3.0 (quilt)' into source/format.",-      Option "" ["native"] (NoArg ((D.sourceFormat . A.debInfo) ~= Just Native3))+      Option "" ["native"] (NoArg ((A.debInfo . D.sourceFormat) ~= Just Native3))              "The package has an no upstream tarball, write '3.0 (native)' into source/format.",-      Option "" ["official"] (NoArg ((D.official . A.debInfo) ~= True))+      Option "" ["official"] (NoArg ((A.debInfo . D.official) ~= True))              "This packaging is created of the official Debian Haskell Group",-      Option "" ["builddir"] (ReqArg (\ s -> (D.buildDir . A.debInfo) ~= Just (s </> "build")) "PATH")+      Option "" ["builddir"] (ReqArg (\ s -> (A.debInfo . D.buildDir) ~= Just (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 "" ["no-test-suite"] (NoArg ((D.noTestSuite . A.debInfo) ~= True))+      Option "" ["no-test-suite"] (NoArg ((A.debInfo . D.noTestSuite) ~= True))              "Don't build or run the test suite.",-      Option "" ["allow-debian-self-build-deps"] (NoArg ((D.allowDebianSelfBuildDeps . A.debInfo) ~= True))-             (unlines [ "Don't filter out self dependencies in the debian package build dependencies."+      Option "" ["allow-debian-self-build-deps"] (NoArg ((A.debInfo . D.allowDebianSelfBuildDeps) ~= True))+             (unlines [ "Set this to allow self dependencies in the debian package build dependencies."                       , "This may occasionally be necessary for a package that relies on an older"-                      , "version of itself to build." ])+                      , "version of itself to build.  It is True by default so that packages which"+                      , "have cabal dependencies on themselves don't get debian self dependencie."+                      , "Cabal self dependencies are now the norm, as when an executable in a package"+                      , "build depends on a library in the same package." ])     ] ++ map liftOpt flagOptions  liftOpt :: Monad m => OptDescr (StateT Flags m ()) -> OptDescr (CabalT m ()) liftOpt (Option chrs strs desc doc) = Option chrs strs (liftDesc desc) doc  liftDesc :: Monad m => ArgDescr (StateT Flags m ()) -> ArgDescr (CabalT m ())-liftDesc (NoArg x) = NoArg (focus (flags . A.debInfo) x)-liftDesc (ReqArg f s) = ReqArg (\ p -> focus (flags . A.debInfo) (f p)) s-liftDesc (OptArg f s) = OptArg (\ mp -> focus (flags . A.debInfo) (f mp)) s+liftDesc (NoArg x) = NoArg (focus (A.debInfo . flags) x)+liftDesc (ReqArg f s) = ReqArg (\ p -> focus (A.debInfo . flags) (f p)) s+liftDesc (OptArg f s) = OptArg (\ mp -> focus (A.debInfo . flags) (f mp)) s  anyrel :: BinPkgName -> Relation anyrel x = Rel x Nothing Nothing@@ -218,7 +221,7 @@ -- addDep' lns arg = mapM_ (\ (b, rel) -> lns b %= (++ [[rel]])) (parseDeps arg)  addDep :: Monad m => (BinPkgName -> Lens DebInfo Relations) -> String -> CabalT m ()-addDep lns arg = mapM_ (\ (b, rel) -> (lns b . A.debInfo) %= (++ [[rel]])) (parseDeps arg)+addDep lns arg = mapM_ (\ (b, rel) -> (A.debInfo . lns b) %= (++ [[rel]])) (parseDeps arg)  parseDeps :: String -> [(BinPkgName, Relation)] parseDeps arg =

@@ -14,13 +14,14 @@     , validateDebianization     ) where +import OldLens (getL)+ import Control.Category ((.)) import Control.Exception as E (throw) import Control.Monad.State (get) import Control.Monad.Trans (liftIO, 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)@@ -34,7 +35,7 @@ import Debian.Debianize.Prelude (indent, replaceFile, zipMaps) import Debian.Debianize.BinaryDebDescription as B (canonical, package) import qualified Debian.Debianize.SourceDebDescription as S-import Debian.Pretty (ppDisplay, ppPrint)+import Debian.Pretty (ppShow, ppPrint) import Prelude hiding ((.), unlines, writeFile) import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions) import System.Exit (ExitCode(ExitSuccess))@@ -73,11 +74,11 @@ doDebianizeAction =     do new <- get        case () of-         _ | getL (validate . D.flags) new ->+         _ | getL (D.flags . validate) new ->                do inputDebianization                   old <- get                   return $ validateDebianization old new-         _ | getL (dryRun . D.flags) new ->+         _ | getL (D.flags . dryRun) new ->                do inputDebianization                   old <- get                   diff <- liftIO $ compareDebianization old new@@ -126,16 +127,16 @@ validateDebianization :: D.DebInfo -> D.DebInfo -> () validateDebianization old new =     case () of-      _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ ppDisplay oldVersion ++ ", found " ++ ppDisplay newVersion))-        | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ ppDisplay oldSource ++ ", found " ++ ppDisplay newSource))+      _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ ppShow oldVersion ++ ", found " ++ ppShow newVersion))+        | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ ppShow oldSource ++ ", found " ++ ppShow newSource))         | oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (map ppPrint oldPackages) ++ ", found " ++ show (map ppPrint newPackages)))         | True -> ()     where       oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL D.changelog old))))       newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL D.changelog new))))-      oldSource = getL (S.source . D.control) old-      newSource = getL (S.source . D.control) new-      oldPackages = map (getL B.package) $ getL (S.binaryPackages . D.control) old-      newPackages = map (getL B.package) $ getL (S.binaryPackages . D.control) new+      oldSource = getL (D.control . S.source) old+      newSource = getL (D.control . S.source) new+      oldPackages = map (getL B.package) $ getL (D.control . S.binaryPackages) old+      newPackages = map (getL B.package) $ getL (D.control . S.binaryPackages) new       unChangeLog :: ChangeLog -> [ChangeLogEntry]       unChangeLog (ChangeLog x) = x

@@ -1,6 +1,6 @@ -- | Functions and instances used by but not related to cabal-debian. -- These could conceivably be moved into more general libraries.-{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, Rank2Types, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.Debianize.Prelude     ( curry3@@ -44,6 +44,9 @@     , fromSingleton     ) where +import OldLens (getL, lens, Lens, modL, setL)+import qualified OldLens as Lens ((%=), (~=))+ import Control.Applicative ((<$>)) import Control.Category ((.)) import Control.Exception as E (bracket, catch, throw, try)@@ -51,8 +54,6 @@ import Control.Monad.Reader (ask, ReaderT) import Control.Monad.State (get, MonadState, put, StateT) import Data.Char (isSpace)-import Data.Lens.Lazy (getL, lens, Lens, modL, setL)-import qualified Data.Lens.Lazy as Lens ((%=), (~=)) import Data.List as List (dropWhileEnd, intersperse, isSuffixOf, lines, map) import Data.Map as Map (empty, findWithDefault, foldWithKey, fromList, insert, insertWith, lookup, map, Map) import Data.Maybe (catMaybes, fromJust, fromMaybe, listToMaybe, mapMaybe)

@@ -25,8 +25,8 @@     , XFieldDest(..)     ) where +import Control.Lens.TH (makeLenses) import Data.Generics (Data, Typeable)-import Data.Lens.Template (makeLenses) import Data.Set as Set (empty, Set) import Data.Text (Text) import Debian.Debianize.BinaryDebDescription (BinaryDebDescription, Canonical(canonical))@@ -133,4 +133,4 @@     | C -- ^ Field will be copied to the upload control (.changes) file     deriving (Eq, Ord, Read, Show, Data, Typeable) -$(makeLenses [''SourceDebDescription])+$(makeLenses ''SourceDebDescription)

@@ -7,13 +7,14 @@     ( substvars     ) where +import OldLens (access, getL, modL)+ import Control.Category ((.)) import Control.Exception (SomeException, try) import Control.Monad (foldM) import Control.Monad.Reader (ReaderT(runReaderT)) import Control.Monad.State (get) import Control.Monad.Trans (lift, liftIO, MonadIO)-import Data.Lens.Lazy (access, getL, modL) import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition, unlines) import Data.List as List (map) import qualified Data.Map as Map (insert, lookup, Map)@@ -27,7 +28,7 @@ import Debian.Debianize.Prelude ((!), buildDebVersionMap, cond, DebMap, debOfFile, diffFile, dpkgFileMap, modifyM, replaceFile, showDeps) import qualified Debian.Debianize.CabalInfo as A (CabalInfo, debInfo, packageDescription, packageInfo, PackageInfo(PackageInfo, cabalName, devDeb, docDeb, profDeb)) import Debian.Orphans ()-import Debian.Pretty (ppDisplay)+import Debian.Pretty (ppShow) import Debian.Relation (BinPkgName(BinPkgName), Relation, Relations) import qualified Debian.Relation as D (BinPkgName(BinPkgName), ParseRelations(parseRelations), Relation(Rel), Relations, VersionReq(GRE)) import Distribution.Compiler (buildCompilerId)@@ -75,13 +76,13 @@           do old <- liftIO $ readFile path'              deps <- debDeps debType control              new <- addDeps old deps-             dry <- get >>= return . getL (dryRun . D.flags . A.debInfo)+             dry <- get >>= return . getL (A.debInfo . D.flags . dryRun)              liftIO (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, _) ->           liftIO $ die ("These debian packages need to be added to the build dependency list so the required cabal " ++-                        "packages are available:\n  " ++ intercalate "\n  " (map (ppDisplay . fst) missing) +++                        "packages are available:\n  " ++ intercalate "\n  " (map (ppShow . 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@@ -203,7 +204,7 @@     where       fixDeps :: [String] -> [Relations]       fixDeps xs = map (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]]-                                           (Map.lookup cab (getL (D.extraLibMap . A.debInfo) atoms))) xs+                                           (Map.lookup cab (getL (A.debInfo . D.extraLibMap) atoms))) xs  -- | Given a control file and a DebType, look for the binary deb with -- the corresponding suffix and return its name.@@ -218,5 +219,5 @@  filterMissing :: Monad m => [[Relation]] -> CabalT m [[Relation]] filterMissing rels =-    do missing <- get >>= return . getL (D.missingDependencies . A.debInfo)+    do missing <- get >>= return . getL (A.debInfo . D.missingDependencies)        return $ filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name missing))) rels)

@@ -9,6 +9,7 @@     -- , ghcNewestAvailableVersion'     -- , ghcNewestAvailableVersion     -- , compilerIdFromDebianVersion+    , compilerPackageName     ) where  import Control.DeepSeq (force)@@ -18,6 +19,7 @@ import Data.Function.Memoize (deriveMemoizable, memoize2) import Data.Maybe (fromMaybe) import Data.Version (showVersion, Version(Version))+import Debian.Debianize.BinaryDebDescription (PackageType(..)) import Debian.Relation (BinPkgName(BinPkgName)) import Debian.Version (DebianVersion, parseDebianVersion) import Distribution.Compiler (CompilerFlavor(..), CompilerId(CompilerId))@@ -60,9 +62,8 @@  newestAvailableCompiler :: FilePath -> CompilerFlavor -> DebianVersion newestAvailableCompiler root hc =-    case debName hc of-      Nothing -> error $ "newestAvailableCompiler - Unsupported CompilerFlavor: " ++ show hc-      Just pkg -> fromMaybe (error $ "newestAvailableCompiler - No versions of " ++ show hc ++ " available in " ++ show root) (newestAvailable root pkg)+    fromMaybe (error $ "newestAvailableCompiler - No versions of " ++ show hc ++ " available in " ++ show root)+              (newestAvailable root (compilerPackageName hc Development))  newestAvailableCompilerId :: FilePath -> CompilerFlavor -> CompilerId newestAvailableCompilerId root hc = compilerIdFromDebianVersion hc (newestAvailableCompiler root hc)@@ -124,8 +125,23 @@       readHC :: String -> a -> a       readHC s = maybe (error $ "Invalid CompilerFlavor: " ++ show s) f (readMaybe (map toUpper s)) +{- debName :: CompilerFlavor -> Maybe BinPkgName debName hc =     case map toLower (show hc) of       s | any isSpace s -> Nothing       s -> Just (BinPkgName s)+-}++compilerPackageName :: CompilerFlavor -> PackageType -> BinPkgName+compilerPackageName GHC Documentation = BinPkgName "ghc-doc" -- "ghc-7.10.1-htmldocs"+compilerPackageName GHC Profiling = BinPkgName "ghc-prof" -- "ghc-7.10.1-prof"+compilerPackageName GHC Development = BinPkgName "ghc" -- "ghc-7.10.1"+compilerPackageName GHC _ = BinPkgName "ghc" -- "ghc-7.10.1" -- whatevs+#if MIN_VERSION_Cabal(1,22,0)+compilerPackageName GHCJS Documentation = BinPkgName "ghcjs"+compilerPackageName GHCJS Profiling = error "Profiling not supported for GHCJS"+compilerPackageName GHCJS Development = BinPkgName "ghcjs"+compilerPackageName GHCJS _ = BinPkgName "ghcjs" -- whatevs+#endif+compilerPackageName x _ = error $ "Unsupported compiler flavor: " ++ show x