diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -600,9 +600,11 @@ test7 label = TestLabel label $ TestCase (do dist <- findBuildDir - new <- readProcessWithExitCode "runhaskell" ["--ghc-arg=-package-db=" ++ dist ++ "/package.conf.inplace", "debian/Debianize.hs", "--dry-run", "--native"] "" + result <- readProcessWithExitCode "runhaskell" ["--ghc-arg=-package-db=" ++ dist ++ "/package.conf.inplace", "debian/Debianize.hs", "--dry-run", "--native"] "" + assertEqual label (ExitSuccess, "Ignored debianization file: debian/cabal-debian.1\nIgnored debianization file: debian/cabal-debian.manpages\nDebianization (dry run):\n No changes\n\n", "") result +{- assertBool label (elem new [(ExitSuccess, "Ignored debianization file: debian/cabal-debian.1\nIgnored debianization file: debian/cabal-debian.manpages\nDebianization (dry run):\n No changes\n\n", ""), - (ExitSuccess, "Ignored debianization file: debian/cabal-debian.manpages\nIgnored debianization file: debian/cabal-debian.1\nDebianization (dry run):\n No changes\n\n", "")])) + (ExitSuccess, "Ignored debianization file: debian/cabal-debian.manpages\nIgnored debianization file: debian/cabal-debian.1\nDebianization (dry run):\n No changes\n\n", "")]) -}) test8 :: String -> Test test8 label = diff --git a/cabal-debian.cabal b/cabal-debian.cabal --- a/cabal-debian.cabal +++ b/cabal-debian.cabal @@ -1,5 +1,5 @@ Name: cabal-debian -Version: 4.31.7 +Version: 4.31.9 Copyright: Copyright (c) 2007-2014, David Fox, Jeremy Shaw License: BSD3 License-File: LICENSE @@ -16,9 +16,8 @@ For documentation of the executable, run @cabal-debian --help@, for documentation of the library API follow the link to the @Debian.Debianize@ module below. -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Extra-Source-Files: - changelog debian/cabal-debian.1 debian/cabal-debian.install debian/cabal-debian.manpages @@ -150,11 +149,6 @@ Description: enable the unit test executable (disabled by default because it has a lot of wacky dependencies.) Default: True -flag local-debian - Description: Link directly to the source of the debian library - Default: True - Manual: True - flag pretty-112 Description: prettyclass was merged into pretty-1.1.2 Default: True @@ -164,6 +158,7 @@ location: https://github.com/ddssff/cabal-debian Library + Default-Language: Haskell2010 Hs-Source-Dirs: src GHC-Options: -Wall -O2 Build-Depends: @@ -172,6 +167,7 @@ Cabal >= 1.18, containers, data-default, + debian >= 3.89, deepseq, Diff >= 0.3.1, directory, @@ -231,85 +227,49 @@ Build-Depends: pretty >= 1.1.2 else Build-Depends: pretty < 1.1.2, prettyclass - 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.89 Executable cabal-debian + Default-Language: Haskell2010 Hs-Source-Dirs: . Main-is: CabalDebian.hs ghc-options: -threaded -Wall -O2 - Build-Depends: base, cabal-debian, Cabal >= 1.18, lens, mtl, pretty, Unixutils >= 1.53 + Build-Depends: + base, + cabal-debian, + Cabal >= 1.18, + debian >= 3.89, + lens, + mtl, + pretty, + Unixutils >= 1.53 if flag(pretty-112) Build-Depends: pretty >= 1.1.2 else Build-Depends: pretty < 1.1.2, prettyclass - if !flag(local-debian) - Build-Depends: debian >= 3.89 Test-Suite cabal-debian-tests + Default-Language: Haskell2010 if !flag(tests) Buildable: False Type: exitcode-stdio-1.0 Hs-Source-Dirs: . Main-is: Tests.hs ghc-options: -threaded -Wall -O2 - Build-Depends: base >= 4.8.1.0, cabal-debian, Cabal >= 1.18, containers, Diff >= 0.3.1, directory, filepath, hsemail, HUnit, lens, process, text + Build-Depends: + base < 5, + cabal-debian, + Cabal >= 1.16, + containers, + debian >= 3.89, + Diff >= 0.3.1, + directory, + filepath, + hsemail, + HUnit, + lens, + process, + text if flag(pretty-112) Build-Depends: pretty >= 1.1.2 else Build-Depends: pretty < 1.1.2, prettyclass - if !flag(local-debian) - Build-Depends: debian >= 3.89 diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,1308 +0,0 @@ -haskell-cabal-debian (4.31.6) unstable; urgency=low - - * Signature change in Debian.Version.parseDebianVersion - - -- David Fox Tue, 22 Sep 2015 06:56:28 -0700 - -haskell-cabal-debian (4.31.5) unstable; urgency=low - - * If there is no Setup.hs or Setup.lhs file we cannot build - debian/hlibrary.setup, therefore we should set DEB_SETUP_BIN_NAME to - "cabal". - - -- David Fox Thu, 17 Sep 2015 08:21:46 -0700 - -haskell-cabal-debian (4.31.4) unstable; urgency=low - - * The test suite was failing during the debian package build because - it assumes the buildDir is in dist/, look for it in dist-ghc/ first. - - -- David Fox Sat, 22 Aug 2015 07:56:04 -0700 - -haskell-cabal-debian (4.31.3) unstable; urgency=low - - * Fix error message formatting (Joachim Breitner) - * Fix test suite result code (Joachim Breitner) - - -- David Fox Fri, 21 Aug 2015 17:29:57 -0700 - -haskell-cabal-debian (4.31.2) unstable; urgency=low - - * Fix some names in Extra-Source-Files and add some missing ones. - - -- David Fox Thu, 20 Aug 2015 16:01:40 -0700 - -haskell-cabal-debian (4.31.1) unstable; urgency=low - - * Map the cabal library Cabal library to the debian library packages - libghc-cabal-dev et. al. - - -- David Fox Thu, 20 Aug 2015 15:48:59 -0700 - -haskell-cabal-debian (4.31) unstable; urgency=low - - * Add some mappings from cabal build tools to debian package names: - ghc -> ghc, alex -> alex, happy -> happy - * Support Multi-Arch field in binaries (Joachim Breitner) - * Implement --roundtrip option (Joachim Breitner) - * Fixes for changelog entry formatting (Joachim Breitner) - * Fixes for License field of debian/copyright (Joachim Breitner) - * Only depend on ghc-doc if the package builds a library - * New mode of operation --upgrade - * No -prof and -doc package dependencies for binary and test suite packages - - -- David Fox Thu, 20 Aug 2015 14:31:28 -0700 - -haskell-cabal-debian (4.30.2) unstable; urgency=low - - * have runDebianizeScript look for source in src/ as well as ./ - - -- David Fox Sat, 08 Aug 2015 08:04:02 -0700 - -haskell-cabal-debian (4.30.1) unstable; urgency=low - - * Make sure apache configuration files end with .conf - - -- David Fox Mon, 29 Jun 2015 10:27:47 -0700 - -haskell-cabal-debian (4.30) unstable; urgency=low - - * Remove mechanism to pass arguments via the CABALDEBIAN environment - variable. - * Make compareDebianization a pure function. - * Remove MonadIO superclass from some functions - - -- David Fox Thu, 18 Jun 2015 09:12:59 -0700 - -haskell-cabal-debian (4.29.3) unstable; urgency=low - - * Fix escaping of wildcard characters that are not meaningful in cabal (i.e. square brackets) - * Fix generation of argument list when running an external debian/Debianization.hs script - (the whole thing was being repeated.) - * Make sure the enable tests and run tests options are handled correctly (not sure they were - wrong, but pretty sure they're now right.) - * Export Dmitry's performDebianization function instead of debianize in Debian.Debianize. - - -- David Fox Sat, 13 Jun 2015 05:24:03 -0700 - -haskell-cabal-debian (4.29) unstable; urgency=low - - * Restore the --epoch-map, --cabal-flag, --ghcjs, and --buildenvdir options - * Export parseProgramArguments' for parsing internally constructed - argument lists. - - -- David Fox Mon, 08 Jun 2015 06:37:25 -0700 - -haskell-cabal-debian (4.28) unstable; urgency=low - - * New command line parsing code from Dmitry Bogatov - * Drop support for old package old package formats - * Bug fixes and typos, API simplification, more - - -- David Fox Wed, 13 May 2015 06:49:04 -0700 - -haskell-cabal-debian (4.27.2) unstable; urgency=low - - * Change to the contents of the init.d file created for server packages. - In Debian.Debianize.Goodies.serverAtoms, insert a line into the init.d - script to set the datadir environment variable to /usr/share/cabalname - before startup. - - -- David Fox Wed, 22 Apr 2015 10:25:52 -0700 - -haskell-cabal-debian (4.27.1) unstable; urgency=low - - * Fix spurious "Just" in debian/copyright file. - - -- David Fox Tue, 21 Apr 2015 07:01:35 -0700 - -haskell-cabal-debian (4.27) unstable; urgency=low - - * Remove all vestiges of the old data-lens package. Thanks to - Dmitry Bogatov for help with this. - - -- David Fox Fri, 17 Apr 2015 15:01:27 -0700 - -haskell-cabal-debian (4.26) unstable; urgency=low - - * Revamp the way the final debian version number is computed in - Debian.Debianize.Finalize.debianVersion. - - -- David Fox Sun, 05 Apr 2015 10:49:33 -0700 - -haskell-cabal-debian (4.25) unstable; urgency=low - - * Make sure /proc is mounted when we run ghc to determine its version - number. This is only a concern when running in a build root. - * Fix whitespace handling bugs in copyright file parser and renderer. - - -- David Fox Sun, 05 Apr 2015 08:14:09 -0700 - -haskell-cabal-debian (4.24.9) unstable; urgency=low - - * Make debian/Debianize.hs a standard debianization script - * Make the test executable into a cabal test suite - * Make ghc-7.10 support official - * Simplify main in CabalDebian.hs - * Get rid of old --substvars option - - -- David Fox Wed, 01 Apr 2015 10:00:45 -0700 - -haskell-cabal-debian (4.24.8) unstable; urgency=low - - * use ghcjs --numeric-ghc-version to set the compilerInfoCompat field - of CompilerInfo. This makes cabal file directives like impl(ghc >= 7.9) - work for ghcjs packages. - - -- David Fox Sun, 29 Mar 2015 12:38:33 -0700 - -haskell-cabal-debian (4.24.7) unstable; urgency=low - - * Remove the Data.Algorithm.Diff modules, they have moved into Diff-0.3.1 - - -- David Fox Tue, 24 Mar 2015 16:51:29 -0700 - -haskell-cabal-debian (4.24.6) unstable; urgency=low - - * Use build dependency haskell-devscripts >= 0.8 for unofficial, >= 0.9 - for official. - * Straighten out the test suite options: --no-tests, --no-run-tests - - -- David Fox Mon, 23 Mar 2015 11:31:14 -0700 - -haskell-cabal-debian (4.24.5) unstable; urgency=low - - * Patch from Dmitry Bogatov for filling in debian/copyright fields - * Patch from Dmitry Bogatov for debhelper and haskell-devscripts build deps - * Patch from Dmitry Bogatov for default changelog message - * Add a --no-run-tests flag to control the nocheck option - * Compatibility with different GHC versions - - -- David Fox Sat, 21 Mar 2015 10:14:48 -0700 - -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 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 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 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 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 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 Fri, 06 Feb 2015 06:25:08 -0800 - -haskell-cabal-debian (4.22) unstable; urgency=low - - * Big module reorganization for more type safety. - - -- David Fox Tue, 03 Feb 2015 13:22:29 -0800 - -haskell-cabal-debian (4.21.1) unstable; urgency=low - - * Fix --buildenvdir command line option. - * Add an option for cabal flags - - -- David Fox Fri, 30 Jan 2015 13:46:08 -0800 - -haskell-cabal-debian (4.21) unstable; urgency=low - - * Split the enormous Atoms record into three layers - the innermost is - Flags, which contains information obtained from the command line - arguments. Flags is also the argument to the inputCabalization - function, which inputs a Cabal PackageDescription. The Flags record - is embedded in a DebInfo, which holds information related to the - Debianization only. The DebInfo and the PackageDescription are used - to build the old Atoms record. DebInfo is the state value of the - DebianT monad, while Atoms is the state value of the CabalT monad. - - The point of all this is to ensure that a PackageDescription exists - before we start converting the Cabalization to a Debianization. - - -- David Fox Thu, 29 Jan 2015 12:29:52 -0800 - -haskell-cabal-debian (4.20.2) unstable; urgency=low - - * Do not lowercase the package name when constructing the data file - destination directory (/usr/share/). - - -- David Fox Fri, 16 Jan 2015 05:45:23 -0800 - -haskell-cabal-debian (4.20.1) unstable; urgency=low - - * Fix a bug in the computation of the debian maintainer field - * Improve rules file generation - - -- David Fox Wed, 14 Jan 2015 14:38:56 -0800 - -haskell-cabal-debian (4.20) unstable; urgency=low - - * Add a --source-section option - * Fix handling of debian maintainer and debian uploaders - * Improve formatting of debian/rules file - * Rename function debianization -> debianize - * Rename function finalizeDebianization' -> finalizeDebianization - * Rename function getDebianMaintainer -> getCurrentDebianUser - - -- David Fox Fri, 09 Jan 2015 11:49:04 -0800 - -haskell-cabal-debian (4.19.3) unstable; urgency=low - - * Fix issue #23, so that if you run 'cabal-debian' and then - 'cabal-debian --compare' it says there are no differences. - * Fix issue #16 - set revision if format is Quilt3. - - -- David Fox Thu, 08 Jan 2015 05:20:32 -0800 - -haskell-cabal-debian (4.19.2) unstable; urgency=low - - * Use canonical to put the debianization in a standard form before - trying to compare existing and generated. - * Fix bug where cabal-debian program processed the command line options - twice. - * Avoid using paths that point to ../ in the cabal file (even if - disabled by a flag), it causes the package to be rejected by hackage. - - -- David Fox Wed, 07 Jan 2015 13:26:33 -0800 - -haskell-cabal-debian (4.19.1) unstable; urgency=low - - * Support Cabal-1.22 - * Test whether apt-file is installed (from creichert) - * Conditional compilation for new symbols MPL and BSD2 (from creichert) - - -- David Fox Wed, 07 Jan 2015 12:56:00 -0800 - -haskell-cabal-debian (4.19) unstable; urgency=low - - * Add remapCabal function here from a private package - * Remove debianVersionSplits, which has long been replaced by - debianDefaultAtoms. - - -- David Fox Mon, 08 Dec 2014 10:07:06 -0800 - -haskell-cabal-debian (4.18) unstable; urgency=low - - * Add types to support machine readable copyright files. - * Add --debian-base-name option and overrideDebianBaseName lens. - * Add --omit-prof-version-deps option flag, have --official imply it - - -- David Fox Thu, 27 Nov 2014 07:11:35 -0800 - -haskell-cabal-debian (4.17.5) unstable; urgency=low - - * Use the prettyclass package and the PP wrappers in the latest - debian package to do pretty printing. - * Change default priority to extra - * Use the new watch file suggested by nomeata - * Use the control file template suggested in issue #3 - - -- David Fox Mon, 15 Sep 2014 13:28:36 -0700 - -haskell-cabal-debian (4.17.4) unstable; urgency=low - - * Add missing ifdefs to hide the GHCJS constructor when ghcjs-support - flag is False. - * Require Cabal < 1.21 when ghcjs-support flag is False. - - -- David Fox Tue, 02 Sep 2014 09:06:20 -0700 - -haskell-cabal-debian (4.17.3) unstable; urgency=low - - * Moved source repository to github.com. - - -- David Fox Fri, 29 Aug 2014 13:55:26 -0700 - -haskell-cabal-debian (4.17.2) unstable; urgency=low - - * Fix formatting of the generated debian/*.install files. - - -- David Fox Tue, 19 Aug 2014 16:04:27 -0700 - -haskell-cabal-debian (4.17.1) unstable; urgency=low - - * Fix install of ghcjs executables - there was an extra subdir. - * Don't append -ghcjs to default package name. - - -- David Fox Tue, 19 Aug 2014 10:15:46 -0700 - -haskell-cabal-debian (4.17) unstable; urgency=low - - * Fix bug in architecture dependent build dependency generation - it - was getting the indep dependencies as well. - * Support GHCJS executable packages, which are directories with the - extension .jsexe. - - -- David Fox Mon, 18 Aug 2014 17:31:35 -0700 - -haskell-cabal-debian (4.16.1) unstable; urgency=low - - * Support for packaging libraries produced by the GHCJS compiler. - * Generate debianizations that include libraries for multiple compiler - flavors (not yet suppored in haskell-devscripts and/or Cabal.) - * Put a DEB_DEFAULT_COMPILER assignment in debian/rules if we can - infer it from the command line options. - - -- David Fox Sat, 16 Aug 2014 07:56:50 -0700 - -haskell-cabal-debian (4.15.2) unstable; urgency=low - - * Lowercase the strings in the extraLibs argument of allBuildDepends - before wrapping them in BinPkgName. Those types, which come from the - debian package, should be opaque and do this whenever a BinPkgName (or - SrcPkgName) is created, because upper case is never ok in Debian - source or binary package names. In the meantime I will make this - requested change. Thanks to Sven Bartscher for pointing this out. - - -- David Fox Tue, 12 Aug 2014 07:47:17 -0700 - -haskell-cabal-debian (4.15.1) unstable; urgency=low - - * Add Data and Typeable instances. - - -- David Fox Thu, 17 Jul 2014 11:22:17 -0700 - -haskell-cabal-debian (4.15) unstable; urgency=low - - * Don't hardcode the compiler name in makefile targets. - - -- David Fox Sat, 12 Jul 2014 12:15:10 -0700 - -haskell-cabal-debian (4.14) unstable; urgency=low - - * Move the code to map the cabal package named "Cabal" to the debian - package named "libghc-cabal-*" from the seereason defaults to the - debian defaults. - - -- David Fox Mon, 07 Jul 2014 08:35:39 -0700 - -haskell-cabal-debian (4.13) unstable; urgency=low - - * Add a flag for ghcjs support. - - -- David Fox Thu, 03 Jul 2014 12:05:21 -0700 - -haskell-cabal-debian (4.12) unstable; urgency=low - - * Remove the Top type and argument - use getWorkingDirectory instead. - - -- David Fox Sun, 29 Jun 2014 08:11:01 -0700 - -haskell-cabal-debian (4.11) unstable; urgency=low - - * Use MonadIO instead of IO for all signatures. This is so - we can more easily use cabal debian from a Shelly script. - - -- David Fox Sun, 29 Jun 2014 07:16:45 -0700 - -haskell-cabal-debian (4.10.1) unstable; urgency=low - - * Fix a tail exception in builtIn. - - -- David Fox Tue, 17 Jun 2014 07:21:22 -0700 - -haskell-cabal-debian (4.10) unstable; urgency=low - - * Rename knownVersionSplits -> debianVersionSplits and move to - Debian.Debianize.Details. (Should that be renamed - Debian.Debianize.Debian?) - * Add HC=ghc or HC=ghcjs to header of debian/rules depending on - the value of the compilerFlavor atom. - - -- David Fox Sat, 14 Jun 2014 10:20:01 -0700 - -haskell-cabal-debian (4.9) unstable; urgency=low - - * Generate the library package prefix, previously hard coded as libghc-, - using the CompilerFlavor value, so we get libghcjs-foo-dev when using - ghcjs. - - -- David Fox Fri, 13 Jun 2014 09:58:13 -0700 - -haskell-cabal-debian (4.8) unstable; urgency=low - - * Add a --no-hoogle flag to omit the hoogle documentation link. This - link doesn't contain the package's version number, so it will conflict - with other versions of the library (such as those built into ghc.) - - -- David Fox Tue, 10 Jun 2014 10:42:38 -0700 - -haskell-cabal-debian (4.7.1) unstable; urgency=low - - * Fix the code added in 4.7. - * Add --recommends and --suggests options, similar to --depends et. al. - - -- David Fox Tue, 03 Jun 2014 07:14:52 -0700 - -haskell-cabal-debian (4.7) unstable; urgency=low - - * Improve the treatment of dependencies which are built into ghc. This - will allow the use of newer libraries than the ones built into ghc, - provided they are given deb names that are different than the one ghc - specifically conflicts with. For example, a newer version of Cabal - could be used if it was in the deb package libghc-cabal-ghcjs-dev. To - change the debian names of libraries we need to use the mapCabal and - splitCabal functions, as is done in the autobuilder-seereason module - Debian.AutoBuilder.Details.Atoms. - - -- David Fox Mon, 02 Jun 2014 14:28:59 -0700 - -haskell-cabal-debian (4.6.2) unstable; urgency=low - - * Move a seereason specific function from here to the - autobuilder-seereason package. - - -- David Fox Mon, 02 Jun 2014 11:03:13 -0700 - -haskell-cabal-debian (4.6.1) unstable; urgency=low - - * Don't compute the current ghc version so often. - - -- David Fox Fri, 30 May 2014 13:40:12 -0700 - -haskell-cabal-debian (4.6) unstable; urgency=low - - * Add a --default-package option to change haskell-packagename-utils to - some other name. - * Fix treatment of cabalfile Data-Dir field - it describes where the - data files are in the source tree, but shouldn't affect where they will - be installed. - - -- David Fox Thu, 29 May 2014 08:27:54 -0700 - -haskell-cabal-debian (4.5) unstable; urgency=low - - * Remove the ghcVersion field and lens. - - -- David Fox Mon, 05 May 2014 11:55:53 -0700 - -haskell-cabal-debian (4.4) unstable; urgency=low - - * Add the copytruncate directive to logrotate files we generate. - As things were, hslogger would continue writing to the deleted - log file after it was rotated. - - -- David Fox Sun, 30 Mar 2014 13:05:48 -0700 - -haskell-cabal-debian (4.3.2) unstable; urgency=low - - * Speed up debianization by computing the ghc version once when - we enter the DebT monad rather than repeatedly. It is slow - because it needs to chroot. - - -- David Fox Fri, 28 Mar 2014 13:03:57 -0700 - -haskell-cabal-debian (4.3.1) unstable; urgency=low - - * Safer default value for buildEnv - "/" instead of "". This is - where we look for the GHC version number. - - -- David Fox Thu, 27 Mar 2014 06:12:28 -0700 - -haskell-cabal-debian (4.3) unstable; urgency=low - - * Make the default value for buildEnv "/", this makes it normally look - at the version number of the ghc compiler installed in the root - environment. - - -- David Fox Mon, 24 Mar 2014 06:01:49 -0700 - -haskell-cabal-debian (4.2) unstable; urgency=low - - * Get the GHC compiler version from the build environment, which - now needs to be explicitly set. - - -- David Fox Fri, 07 Mar 2014 10:58:37 -0800 - -haskell-cabal-debian (4.1.1) unstable; urgency=low - - * Remove build dependency on ansi-wl-pprint. - * Split module Debian.Debianize.BuildDependencies out of - Debian.Debianize.Finalize - - -- David Fox Sun, 02 Feb 2014 07:37:03 -0800 - -haskell-cabal-debian (4.0.6) unstable; urgency=low - - * Ifdef out duplicate instances for Cabal-1.18.0 - thanks to Tom Nielsen. - - -- David Fox Tue, 28 Jan 2014 17:10:48 -0800 - -haskell-cabal-debian (4.0.5) unstable; urgency=low - - * Changes for debian-3.81 - use the pretty printer in Debian.Pretty - instead of ansi-wl-pprint. - - -- David Fox Tue, 14 Jan 2014 05:02:59 -0800 - -haskell-cabal-debian (4.0.4) unstable; urgency=low - - * Restore the test data, the problem I had with long filenames - is solved by using cabal sdist to create the tarball rather - than runhaskell Setup sdist. - - -- David Fox Wed, 18 Dec 2013 09:37:34 -0800 - -haskell-cabal-debian (4.0.3) unstable; urgency=low - - * Include the build dependencies of the executables in the debian - source deb build dependencies. - - -- David Fox Tue, 10 Dec 2013 14:37:20 -0800 - -haskell-cabal-debian (4.0.2) unstable; urgency=low - - * Export some lens state operators from Prelude. - - -- David Fox Tue, 10 Dec 2013 05:38:00 -0800 - -haskell-cabal-debian (4.0.1) unstable; urgency=low - - * Make sure the utilities package gets created even if no name - has been specified for it - use the name generated in DebianNames.hs. - - -- David Fox Tue, 10 Dec 2013 05:10:11 -0800 - -haskell-cabal-debian (4.0.0) unstable; urgency=low - - * Massive lens overhaul - - -- David Fox Thu, 05 Dec 2013 12:26:31 -0800 - -haskell-cabal-debian (3.10.3) unstable; urgency=low - - * Go back to using lens interface directly - * Collect debianization fact code in Facts/ - - -- David Fox Sun, 24 Nov 2013 10:40:02 -0800 - -haskell-cabal-debian (3.10.2) unstable; urgency=low - - * Make some signatures in Monad.hs clearer - - -- David Fox Wed, 20 Nov 2013 14:26:28 -0800 - -haskell-cabal-debian (3.10.1) unstable; urgency=low - - * More API changes - want need to get all the clients in sync before - proceeding. - - -- David Fox Tue, 19 Nov 2013 11:31:16 -0800 - -haskell-cabal-debian (3.10) unstable; urgency=low - - * Add a monadic interface - - -- David Fox Sat, 16 Nov 2013 10:42:02 -0800 - -haskell-cabal-debian (3.9) unstable; urgency=low - - * Clean up documentation - * Allow more than one utility package name, each of which will - get copies of the data-files and leftover executables. - * Make the --debianize option a no-op, the behavior is now the - default. - * Update the unit tests and build an executable to run them. - * Copy debian/changelog to top directory at beginning of build - so hackage will see it. - - -- David Fox Tue, 05 Nov 2013 11:34:48 -0800 - -haskell-cabal-debian (3.8.3) unstable; urgency=low - - * Add an ifdef for compatibility with GHC-7.4.1. - - -- David Fox Sun, 20 Oct 2013 15:50:47 -0700 - -haskell-cabal-debian (3.8.2) unstable; urgency=low - - * Actually, copy changelog from debian/changelog before - building sdist tarball. - - -- David Fox Tue, 15 Oct 2013 06:42:39 -0700 - -haskell-cabal-debian (3.8.1) unstable; urgency=low - - * Move changelog top top directory so hackage will see it. - - -- David Fox Tue, 15 Oct 2013 06:24:25 -0700 - -haskell-cabal-debian (3.8) unstable; urgency=low - - * Downcase the package name to build the datadir name in /usr/share, - this matches the paths in dist/autogen/Paths_packagename. - - -- David Fox Mon, 14 Oct 2013 20:48:39 -0700 - -haskell-cabal-debian (3.7) unstable; urgency=low - - * Change path to hackage tarball in watch file for hackage2. - - -- David Fox Fri, 04 Oct 2013 09:22:51 -0700 - -haskell-cabal-debian (3.6) unstable; urgency=low - - * Require haskell-devscripts >= 0.8.19. This version changes the - value of datasubdir from /usr/share/packagename-packageversion to - simply /usr/share/packagename. This could break some packaging. - - -- David Fox Fri, 06 Sep 2013 16:48:18 -0700 - -haskell-cabal-debian (3.5) unstable; urgency=low - - * Allow full lists of debian relations to be passed to the --build-dep - argument, not just a single package name. - - -- David Fox Sun, 01 Sep 2013 07:08:37 -0700 - -haskell-cabal-debian (3.4.3) unstable; urgency=low - - * Fix the repository location in the cabal file. - - -- David Fox Sat, 31 Aug 2013 07:57:15 -0700 - -haskell-cabal-debian (3.4.2) unstable; urgency=low - - * Notify user when debhelper isn't installed. - * Avoid use of partial function read - - -- David Fox Mon, 24 Jun 2013 13:51:51 -0700 - -haskell-cabal-debian (3.4.1) unstable; urgency=low - - * Remove call to test script in Setup.hs - * Remove unused dependencies - - -- David Fox Mon, 10 Jun 2013 09:12:38 -0700 - -haskell-cabal-debian (3.4) unstable; urgency=low - - * Add support for modifying the Provides and Replaces fields. - - -- David Fox Sun, 09 Jun 2013 14:18:39 -0700 - -haskell-cabal-debian (3.3.2) unstable; urgency=low - - * Changes for debian-3.71 - - -- David Fox Sun, 14 Apr 2013 13:32:04 -0700 - -haskell-cabal-debian (3.3.1) unstable; urgency=low - - * Don't fail during dry run if the existing debianization has no - copyright file. - - -- David Fox Wed, 13 Mar 2013 10:00:25 -0700 - -haskell-cabal-debian (3.3) unstable; urgency=low - - * Add Debian.Debianize.Details, with default Atoms values for Debian and - SeeReason. - - -- David Fox Mon, 11 Mar 2013 11:44:10 -0700 - -haskell-cabal-debian (3.2.5) unstable; urgency=low - - * Add move the VersionSplits type into a module, and fix the code that - splits the mapping of cabal to debian names over a version range. - - -- David Fox Tue, 05 Mar 2013 05:17:03 -0800 - -haskell-cabal-debian (3.2.4) unstable; urgency=low - - * Fix long standing bug in Debian.Debianize.Interspersed.foldTriples. - - -- David Fox Sun, 03 Mar 2013 09:45:14 -0800 - -haskell-cabal-debian (3.2.3) unstable; urgency=low - - * Clean up mapping from cabal names to debian names. - - -- David Fox Sat, 02 Mar 2013 07:36:16 -0800 - -haskell-cabal-debian (3.2.2) unstable; urgency=low - - * Remove unused Debian.Debianize.Generic and Triplets modules. - - -- David Fox Fri, 01 Mar 2013 11:14:33 -0800 - -haskell-cabal-debian (3.2.1) unstable; urgency=low - - * Do not add the options +RTS -IO -RTS to the server options, this - is a security risk. Instead, server executables should built with - -with-rtsopts=-IO. - - -- David Fox Thu, 28 Feb 2013 09:02:39 -0800 - -haskell-cabal-debian (3.2) unstable; urgency=low - - * Strip executables when installing (well, at least some. There - may be more work to do here.) - * Change the build dependency type from BinPkgName to Relation, so we - can specify version dependencies (though as yet not or relations.) - - -- David Fox Tue, 26 Feb 2013 07:17:30 -0800 - -haskell-cabal-debian (3.1.1) unstable; urgency=low - - * Fix the code in the init file that checks for and sources a - file in /etc/default. - - -- David Fox Mon, 25 Feb 2013 14:46:02 -0800 - -haskell-cabal-debian (3.1) unstable; urgency=low - - * Create a Top type to represent the top directory of a debianization - * Change the signature of Debian.Debianize.debianization so it notices - command line arguments and environment arguments. - - -- David Fox Fri, 22 Feb 2013 13:28:30 -0800 - -haskell-cabal-debian (3.0.7) unstable; urgency=low - - * Fix to copyright/license code - * have the init script load /etc/default/packagename if available - * Add an alternative function to showCommandForUser (called showCommand) - that uses double quotes instead of single quotes so you can reference - shell variables. - - -- David Fox Wed, 20 Feb 2013 09:29:11 -0800 - -haskell-cabal-debian (3.0.6) unstable; urgency=low - - * When packaging a web site or server, don't add code to the postinst - to start a server, it gets generated by debhelper. - * Add the changelog and the Debianize.hs file to extra-source-files. - * Add HTTP=1 to the list of known epoch mappings. - - -- David Fox Thu, 14 Feb 2013 14:41:17 -0800 - -haskell-cabal-debian (3.0.5) unstable; urgency=low - - * Compatibility with ghc-7.4 - - -- David Fox Wed, 13 Feb 2013 10:48:19 -0800 - -haskell-cabal-debian (3.0.4) unstable; urgency=low - - * Add dependency on debian-policy, so we can compute the latest - standards-version. - * Documentation improvements - * Test case improvements - * Error message improvements - - -- David Fox Sun, 10 Feb 2013 11:03:55 -0800 - -haskell-cabal-debian (3.0.3) unstable; urgency=low - - * Due to a typo, the noDocumentationLibrary lens was turning off - profiling rather than documentation. - - -- David Fox Fri, 08 Feb 2013 17:14:09 -0800 - -haskell-cabal-debian (3.0.2) unstable; urgency=low - - * Fix argument and exception handling in cabal-debian - * Make Standards-Version field non-mandatory - * Make sure every binary deb paragraph has a non-empty description - - -- David Fox Thu, 07 Feb 2013 10:03:25 -0800 - -haskell-cabal-debian (3.0.1) unstable; urgency=low - - * Don't build Debian version numbers with revision (Just ""). - * Output the descriptions of the binary packages. - - -- David Fox Tue, 05 Feb 2013 14:48:33 -0800 - -haskell-cabal-debian (3.0) unstable; urgency=low - - * Moved the Distribution.Debian modules to Debian.Cabal and - Debian.Debianize. - * Refactored the debianize function for easier testing - * Added test cases. - * Add a Debianization type that intends to fully describe a debian - package, with functions to read, build, modify, and write a - Debianization. - - -- David Fox Wed, 26 Dec 2012 05:45:35 -0800 - -haskell-cabal-debian (2.6.3) unstable; urgency=low - - * Fix pretty printing of Relations (i.e. dependency lists.) There - is an instance for printing lists in ansi-wl-pprint which prevents - us from writing customized Pretty instances for type aliases like - Relations, AndRelation, and OrRelation. - - -- David Fox Fri, 04 Jan 2013 09:30:48 -0800 - -haskell-cabal-debian (2.6.2) unstable; urgency=low - - * Fix a bug constructing the destination pathnames that was dropping - files that were supposed to be installed into packages. - - -- David Fox Thu, 20 Dec 2012 06:49:25 -0800 - -haskell-cabal-debian (2.6.1) unstable; urgency=low - - * Remove the modifyAtoms field from the Flags record, we want to - be able to create instances like Read and Show for this type. - The modifyAtoms function is now passed separately to debianize. - * The flags field of Server was renamed serverFlags because the - newly exported Config record has a flags field. - - -- David Fox Wed, 19 Dec 2012 09:45:22 -0800 - -haskell-cabal-debian (2.5.10) unstable; urgency=low - - * Filter cabal self dependencies out before generating - Build-Depends-Indep, just as we added code to filter them out - of Build-Depends in version 2.5.7. - - -- David Fox Tue, 18 Dec 2012 13:23:39 -0800 - -haskell-cabal-debian (2.5.9) unstable; urgency=low - - * Always add +RTS -IO -RTS to server flags. - - -- David Fox Sun, 16 Dec 2012 10:40:52 -0800 - -haskell-cabal-debian (2.5.8) unstable; urgency=low - - * Add a builtin list for ghc-7.6.1. - - -- David Fox Sat, 15 Dec 2012 07:04:49 -0800 - -haskell-cabal-debian (2.5.7) unstable; urgency=low - - * Filter out cabal self-dependencies before building the debian - dependencies. In cabal a self dependency means you need the library - to build an executable, while in debian it means you need an older - version installed to build the current version. - - -- David Fox Thu, 29 Nov 2012 08:42:30 -0800 - -haskell-cabal-debian (2.5.6) unstable; urgency=low - - * Don't add --base-uri and --http-port arguments automatically, they can be - computed by calling the oldClckwrksFlags function and adding the value to - the flags field. Clckwrks-0.3 no longer needs the --base-uri argument. - - -- David Fox Tue, 27 Nov 2012 13:34:31 -0800 - -haskell-cabal-debian (2.5.5) unstable; urgency=low - - * Have the debianize function return False if there is no debian/Debianize.hs file, - but throw an exception if running it failed, so we notice bad debianization code. - - -- David Fox Tue, 27 Nov 2012 07:34:51 -0800 - -haskell-cabal-debian (2.5.4) unstable; urgency=low - - * Insert "SetEnv proxy-sendcl 1" line into Apache config. - - -- David Fox Tue, 20 Nov 2012 13:43:54 -0800 - -haskell-cabal-debian (2.5.3) unstable; urgency=low - - * Remove extra copy of binary from the executable debs - * Add a sourcePackageName field to Flags, and a --source-package-name - command line option. - - -- David Fox Sat, 17 Nov 2012 00:16:21 -0800 - -haskell-cabal-debian (2.5.2) unstable; urgency=low - - * Fix the path to where the DHInstallTo and DHInstallCabalExecTo - DebAtoms put their files. - - -- David Fox Fri, 16 Nov 2012 18:11:45 -0800 - -haskell-cabal-debian (2.5.1) unstable; urgency=low - - * Add a destName field to Executable so we can give installed - executables a different name than they had in the build. - - -- David Fox Fri, 16 Nov 2012 15:37:16 -0800 - -haskell-cabal-debian (2.5) unstable; urgency=low - - * Add a debName field to the Executable record, before the deb - package name had to equal the executable name. - - -- David Fox Fri, 16 Nov 2012 12:32:39 -0800 - -haskell-cabal-debian (2.4.2) unstable; urgency=low - - * Move location of cabal install files from dist/build/install to - debian/cabalInstall, the dist directory was getting wiped at bad - moments. - * Split the autobuilder function autobuilderDebianize into two - new functions in cabal-debian: runDebianize and callDebianize. - * Custom debianization code now goes in debian/Debianize.hs rather than - in setup, so we can distinguish it failing from it not existing more - easily. - - -- David Fox Thu, 15 Nov 2012 11:00:08 -0800 - -haskell-cabal-debian (2.4.1) unstable; urgency=low - - * We need to verify that debian/compat was created after running the - debianize function, because ghc still exits with ExitSuccess - - -- David Fox Thu, 15 Nov 2012 06:34:02 -0800 - -haskell-cabal-debian (2.4.0) unstable; urgency=low - - * You can run a function in Setup.hs other than main using ghc -e, so we - will use this trick to run the debianize function directly rather than - running main. - * Eliminate the autobuilderDebianize function. - - -- David Fox Thu, 15 Nov 2012 04:05:49 -0800 - -haskell-cabal-debian (2.3.4) unstable; urgency=low - - * Fix the builddir used when running the cabal-debian standalone - executable - it was dist-cabal/build, so the resulting debianization - had files in places where cabal didn't expect them. - - -- David Fox Tue, 13 Nov 2012 06:20:51 -0800 - -haskell-cabal-debian (2.3.3) unstable; urgency=low - - * Eliminate class MonadBuild and the BuildT monad. - - -- David Fox Sun, 11 Nov 2012 17:46:31 -0800 - -haskell-cabal-debian (2.3.2) unstable; urgency=low - - * Fix exception that was keeping changelogs from being preserved. - - -- David Fox Sat, 10 Nov 2012 10:07:50 -0800 - -haskell-cabal-debian (2.3.1) unstable; urgency=low - - * Fix the extension of the debhelper links files - * Add a general mechanism for installing a file into a deb when - we have the file's text in a String (rather than in a file.) - - -- David Fox Sat, 10 Nov 2012 07:35:09 -0800 - -haskell-cabal-debian (2.3) unstable; urgency=low - - * Add MonadBuild. - - -- David Fox Fri, 09 Nov 2012 12:21:14 -0800 - -haskell-cabal-debian (2.2.1) unstable; urgency=low - - * Add a modifyAtoms function to Flags that is applied to final list of - DebAtom before writing the debianization. - * Add DHApacheSite and DHInstallCabalExec atoms so atoms don't depend on - the build directory - * Add #DEBHELPER# and exit 0 to default web server postinst. - - -- David Fox Fri, 09 Nov 2012 10:25:32 -0800 - -haskell-cabal-debian (2.2.0) unstable; urgency=low - - * Append a trailing slash to the --base-uri argument passed to the - server. This is required by Web.Routes.Site.runSite. - - -- David Fox Thu, 08 Nov 2012 04:40:08 -0800 - -haskell-cabal-debian (2.1.4) unstable; urgency=low - - * Merge the Executable and Script constructors of the Executable type - * Add a destDir field to Executable to specify the destination. - - -- David Fox Tue, 06 Nov 2012 13:24:25 -0800 - -haskell-cabal-debian (2.1.3) unstable; urgency=low - - * Don't append a slash to the base-uri. - * Construct the name of the data directory in /usr/share from the cabal - package name rather than the debian source package name. - * Add a --self-depend flag to include a build dependency on this library - in all generated debianizations. - - -- David Fox Tue, 06 Nov 2012 07:07:57 -0800 - -haskell-cabal-debian (2.1.2) unstable; urgency=low - - * Output the server support files. - - -- David Fox Tue, 06 Nov 2012 06:37:18 -0800 - -haskell-cabal-debian (2.1.1) unstable; urgency=low - - * Restore code that checks for version number match when validating - a debianization. The autobuilder can now pass the version number - to cabal-debian, so it should match. - - -- David Fox Mon, 05 Nov 2012 17:42:32 -0800 - -haskell-cabal-debian (2.1.0) unstable; urgency=low - - * Enable processing of Script, Server and WebSite executables. - - -- David Fox Mon, 05 Nov 2012 12:45:42 -0800 - -haskell-cabal-debian (2.0.9) unstable; urgency=low - - * Add a Library section, export all the modules. - - -- David Fox Mon, 05 Nov 2012 06:41:25 -0800 - -haskell-cabal-debian (2.0.8) unstable; urgency=low - - * Bypass abandoned versions. - - -- David Fox Sat, 03 Nov 2012 06:13:27 -0700 - -haskell-cabal-debian (1.26) unstable; urgency=low - - * Don't try to update the existing debianization, except for the - changelog where we retain entries that look older than the one - we generate. - * Use .install files instead of adding rules to debian/rules - * Add --depends and --conflicts options - - -- David Fox Thu, 25 Oct 2012 12:03:49 -0700 - -haskell-cabal-debian (1.25) unstable; urgency=low - - * If the --disable-haddock flag is given omit the doc package from the - control file. - * The tarball that was uploaded to Hackage as version 1.24 had a (buggy) - change which was not pushed to darcs. This resolves that confusion. - - -- David Fox Sat, 16 Jun 2012 14:42:12 -0700 - -haskell-cabal-debian (1.24) unstable; urgency=low - - * No wonder it doesn't build on hackage - none of the source - modules were shipped. - - -- David Fox Thu, 14 Jun 2012 08:19:19 -0700 - -haskell-cabal-debian (1.23) unstable; urgency=low - - * Add a --quilt option to switch from native to quilt format. - Without this option the file debian/source/format will contain - '3.0 (native)', with it '3.0 (quilt)'. - - -- David Fox Fri, 01 Jun 2012 05:53:36 -0700 - -haskell-cabal-debian (1.22) unstable; urgency=low - - * Bump version to make sure all changes are uploaded. - - -- David Fox Wed, 23 May 2012 19:54:17 -0700 - -haskell-cabal-debian (1.21) unstable; urgency=low - - * fix conversion of wildcards into intersected ranges - - -- David Fox Wed, 23 May 2012 19:51:34 -0700 - -haskell-cabal-debian (1.20) unstable; urgency=low - - * Fix generation of debian library dependencies from the Extra-Libraries - field of the cabal file. - - -- David Fox Wed, 23 May 2012 19:50:39 -0700 - -haskell-cabal-debian (1.19) unstable; urgency=low - - * Handle cabal equals dependencies. - - -- David Fox Tue, 20 Mar 2012 14:34:58 -0700 - -haskell-cabal-debian (1.18) unstable; urgency=low - - * High level of confidence this time. Interesting new Interspersed - class, and an implementation of invertVersionRanges which should be - forwarded to the Cabal folks. - * Removes dependency on logic-classes - - -- David Fox Tue, 20 Mar 2012 08:17:25 -0700 - -haskell-cabal-debian (1.17) unstable; urgency=low - - * Restore code to downcase cabal package name before using it as the - base of the debian package name. - - -- David Fox Sun, 18 Mar 2012 15:32:04 -0700 - -haskell-cabal-debian (1.16) unstable; urgency=low - - * Remove code that implements a special case for the debian name of the - haskell-src-exts package. - - -- David Fox Sun, 18 Mar 2012 14:11:21 -0700 - -haskell-cabal-debian (1.15) unstable; urgency=low - - * Yet another stab at fixing the code for converting cabal dependencies - to debian dependencies, with support for splitting version ranges of - cabal files among different debian packages. - - -- David Fox Fri, 16 Mar 2012 17:59:28 -0700 - -haskell-cabal-debian (1.14) unstable; urgency=low - - * Don't try to strip data files - * Use permissions 644 for data files, not 755. - - -- David Fox Wed, 07 Mar 2012 14:46:04 -0800 - -haskell-cabal-debian (1.13) unstable; urgency=low - - * Append the version number when constructing the directory for data - files. - - -- David Fox Wed, 07 Mar 2012 08:56:39 -0800 - -haskell-cabal-debian (1.12) unstable; urgency=low - - * Include any files listed in the Data-Files field of the cabal file - in the utils package. - - -- David Fox Tue, 06 Mar 2012 11:31:47 -0800 - -haskell-cabal-debian (1.11) unstable; urgency=low - - * Replace --epoch flag with --epoch-map, so we can specify epoch numbers - for both the package being built and for dependency packages. - - -- David Fox Thu, 09 Feb 2012 07:01:19 -0800 - -haskell-cabal-debian (1.10) unstable; urgency=low - - * Add bundled package list for ghc 7.4.1. - - -- David Fox Sat, 04 Feb 2012 14:44:33 -0800 - -haskell-cabal-debian (1.9) unstable; urgency=low - - * Add --dep-map flag to allow mapping of cabal package names to the base - of a debian package name. This modifies the name to which the prefix - "lib" and the suffix "-dev" are added. - * Fix dependency generation bug introduced in 1.8. - - -- David Fox Mon, 23 Jan 2012 14:13:05 -0800 - -haskell-cabal-debian (1.8) unstable; urgency=low - - * Add a --dev-dep flag to make one or more packages install dependencies - of the dev package. - - -- David Fox Mon, 23 Jan 2012 05:00:46 -0800 - -haskell-cabal-debian (1.7) unstable; urgency=low - - * Add info about ghc 7.4.0 pre-release. - - -- David Fox Wed, 11 Jan 2012 09:57:45 -0800 - -haskell-cabal-debian (1.6) unstable; urgency=low - - * Don't omit dependencies built into ghc, they should be satisfied by - the Provides in the compiler if they are not available in the - repository. However, we do need to make ghc an alterantive to any - versioned dependencies that are bundled with the compiler, since the - built in dependencies are virtual packages and thus unversioned. - - -- David Fox Wed, 07 Dec 2011 06:10:17 -0800 - -haskell-cabal-debian (1.5) unstable; urgency=low - - * Fix the generation of build dependency version ranges by using an - intermediate version range type. - * If the version range for the cabal file touches two different debian - package, don't try to write build dependencies that allow either one, - it can't really be done. Just give the allowable versions of the - newer package (e.g. libghc-parsec3-dev rather than libghc-parsec2-dev.) - - -- David Fox Sun, 04 Dec 2011 05:59:25 -0800 - -haskell-cabal-debian (1.4) unstable; urgency=low - - * Add a --revision flag which appends a (perhaps empty) string - cabal version number to get the debian version number. Without this - flag the string "-1~hackage1" is appended. - * Make it an error to specify a debian version via --deb-version that is - older than the current cabal version. - - -- David Fox Sun, 20 Nov 2011 06:45:33 -0800 - -haskell-cabal-debian (1.3) unstable; urgency=low - - * Fix error message when compiler version is not in bundled package list. - * Add bundled package list for compiler 7.0.4 (same as 7.0.3.) - - -- David Fox Sat, 08 Oct 2011 07:58:19 -0700 - -haskell-cabal-debian (1.2) unstable; urgency=low - - * When computing the debian name from a package's cabal name, if we - have no particular version number we are comparing to, use the name - from the version split that corresponds to newer version numbers. - * Add code to make the cabal package haskell-src-exts map to the debian - packages libghc-src-exts-dev etc. Normally it would map to - libghc-haskell-src-exts-dev. - - -- David Fox Thu, 06 Oct 2011 09:27:02 -0700 - -haskell-cabal-debian (1.1) unstable; urgency=low - - * Use propositional logic package to compute normal form for dependencies - * Make sure to correct format of cabal package synopsis before using as debian - package description. - - -- David Fox Fri, 30 Sep 2011 06:16:34 -0700 - -haskell-cabal-debian (1.0) unstable; urgency=low - - * Debianization generated by cabal-debian - - -- David Fox Sun, 18 Sep 2011 06:40:21 -0700 diff --git a/debian-haskell/Debian/Apt/Dependencies.hs b/debian-haskell/Debian/Apt/Dependencies.hs deleted file mode 100644 --- a/debian-haskell/Debian/Apt/Dependencies.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# 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 Debian.Version.ByteString () -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 (_, str))) -> - case parseDebianVersion str of - Right ver -> (BinPkgName (C.unpack (stripWS name)), ver) - Left e -> error $ "packageVersionParagraph: " ++ show e - (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 - - diff --git a/debian-haskell/Debian/Apt/Index.hs b/debian-haskell/Debian/Apt/Index.hs deleted file mode 100644 --- a/debian-haskell/Debian/Apt/Index.hs +++ /dev/null @@ -1,300 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, 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 diff --git a/debian-haskell/Debian/Apt/Methods.hs b/debian-haskell/Debian/Apt/Methods.hs deleted file mode 100644 --- a/debian-haskell/Debian/Apt/Methods.hs +++ /dev/null @@ -1,486 +0,0 @@ -{-# 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 -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. - -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) --} diff --git a/debian-haskell/Debian/Apt/Package.hs b/debian-haskell/Debian/Apt/Package.hs deleted file mode 100644 --- a/debian-haskell/Debian/Apt/Package.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# 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) diff --git a/debian-haskell/Debian/Arch.hs b/debian-haskell/Debian/Arch.hs deleted file mode 100644 --- a/debian-haskell/Debian/Arch.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# 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" diff --git a/debian-haskell/Debian/Changes.hs b/debian-haskell/Debian/Changes.hs deleted file mode 100644 --- a/debian-haskell/Debian/Changes.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# 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 [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 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 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 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 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 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 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) Wed, 21 Nov 2007 01:26:57 +0000"] diff --git a/debian-haskell/Debian/Control.hs b/debian-haskell/Debian/Control.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- |A module for working with Debian control files -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 diff --git a/debian-haskell/Debian/Control/ByteString.hs b/debian-haskell/Debian/Control/ByteString.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control/ByteString.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# LANGUAGE CPP, 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 - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) -#endif -import Control.Applicative (Alternative(..)) -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 Functor (Parser state) where - fmap f m = - Parser $ \ state -> - let r = (unParser m) state in - case r of - Ok (a,state') -> Ok (f a,state') - Empty -> Empty - Fail -> Fail - -instance Applicative (Parser state) where - pure = return - (<*>) = ap - -instance Alternative (Parser state) where - empty = - Parser $ \state -> - (unParser mzero) state - (<|>) = mplus - -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) - - -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) diff --git a/debian-haskell/Debian/Control/Common.hs b/debian-haskell/Debian/Control/Common.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control/Common.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# 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 diff --git a/debian-haskell/Debian/Control/Policy.hs b/debian-haskell/Debian/Control/Policy.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control/Policy.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# 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 diff --git a/debian-haskell/Debian/Control/String.hs b/debian-haskell/Debian/Control/String.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control/String.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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") diff --git a/debian-haskell/Debian/Control/Text.hs b/debian-haskell/Debian/Control/Text.hs deleted file mode 100644 --- a/debian-haskell/Debian/Control/Text.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# 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, dropAround, 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.dropAround (`elem` (" \t" :: String)) - -- T.strip would also strip newlines - 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 --} diff --git a/debian-haskell/Debian/Deb.hs b/debian-haskell/Debian/Deb.hs deleted file mode 100644 --- a/debian-haskell/Debian/Deb.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# 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 diff --git a/debian-haskell/Debian/Extra/Files.hs b/debian-haskell/Debian/Extra/Files.hs deleted file mode 100644 --- a/debian-haskell/Debian/Extra/Files.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# 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" diff --git a/debian-haskell/Debian/GenBuildDeps.hs b/debian-haskell/Debian/GenBuildDeps.hs deleted file mode 100644 --- a/debian-haskell/Debian/GenBuildDeps.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE CPP, 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 - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Exception (throw) -import Control.Monad (filterM, foldM) -import Control.Monad.State (evalState, get, modify, State) -import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc) -import Data.List as List (elemIndex, find, map, nub, partition, tails) -import Data.Map as Map (empty, findWithDefault, fromList, insert, Map, lookup) -import Data.Maybe -import Data.Set as Set (fromList, intersection, null, 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 Debug.Trace (trace) -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?) - , depSet :: Set.Set BinPkgName -- ^ Set containing all binary package names mentioned in relations - , binSet :: Set.Set BinPkgName -- ^ Set containing binaryNames - } 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 --- -buildDependencies :: HasDebianControl control => control -> DepInfo -buildDependencies control = do - let rels = concat [fromMaybe [] (debianBuildDeps control), - fromMaybe [] (debianBuildDepsIndep control)] - bins = debianBinaryPackageNames control - DepInfo { sourceName = debianSourcePackageName control - , relations = rels - , binaryNames = bins - , depSet = Set.fromList (List.map (\(Rel x _ _) -> x) (concat rels)) - , binSet = Set.fromList bins } - --- | 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 = - List.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 (/= []) (List.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 on the - -- yet-to-be-built packages - 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 = List.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 = List.map (makeReady blocked allReady) allReady - , allBlocked = List.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 = List.map ofVertex directlyBlocked - , other = List.map ofVertex (otherReady ++ otherBlocked) } - --allDeps x = (ofVertex x, List.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 = -#if 0 - nub (foldr f [] (tails vertPairs)) - where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)] - f [] es = es - f (x : xs) es = catMaybes (List.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) -#else - nub (evalState (foldM f [] (tails vertPairs)) Map.empty) - where f :: [(Int, Int)] -> [(Int, DepInfo)] -> State (Map.Map (Int, Int) Ordering) [(Int, Int)] - f es [] = return es - f es (x : xs) = mapM (toEdge x) xs >>= \es' -> return (catMaybes es' ++ es) - toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> State (Map.Map (Int, Int) Ordering) (Maybe Edge) - toEdge (xv, xa) (yv, ya) = do - mp <- get - r <- case Map.lookup (xv, yv) mp of - Just r' -> return r' - Nothing -> do - let r' = compareSource xa ya - -- trace ("compareSource " ++ show (unSrcPkgName $ sourceName xa) ++ " " ++ show (unSrcPkgName $ sourceName ya) ++ " -> " ++ show r') (return ()) - modify (Map.insert (xv, yv) r') - return r' - case r of - EQ -> return Nothing - LT -> return $ Just (yv, xv) - GT -> return $ Just (xv, yv) -#endif - 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 p1 p2 -#if 0 - | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p2))) (concat (relations p1)) = GT - | any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p1))) (concat (relations p2)) = LT - | otherwise = EQ - where - checkPackageNameReq :: Relation -> BinPkgName -> Bool - checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName -#else - | not (Set.null (Set.intersection (depSet p1) (binSet p2))) = GT - | not (Set.null (Set.intersection (depSet p2) (binSet p1))) = LT - | otherwise = EQ -#endif - -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 diff --git a/debian-haskell/Debian/Loc.hs b/debian-haskell/Debian/Loc.hs deleted file mode 100644 --- a/debian-haskell/Debian/Loc.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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)) diff --git a/debian-haskell/Debian/Pretty.hs b/debian-haskell/Debian/Pretty.hs deleted file mode 100644 --- a/debian-haskell/Debian/Pretty.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | 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 diff --git a/debian-haskell/Debian/Relation.hs b/debian-haskell/Debian/Relation.hs deleted file mode 100644 --- a/debian-haskell/Debian/Relation.hs +++ /dev/null @@ -1,25 +0,0 @@ --- |A module for working with debian relationships -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 diff --git a/debian-haskell/Debian/Relation/ByteString.hs b/debian-haskell/Debian/Relation/ByteString.hs deleted file mode 100644 --- a/debian-haskell/Debian/Relation/ByteString.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} --- |A module for working with debian relationships -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) diff --git a/debian-haskell/Debian/Relation/Common.hs b/debian-haskell/Debian/Relation/Common.hs deleted file mode 100644 --- a/debian-haskell/Debian/Relation/Common.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# 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 diff --git a/debian-haskell/Debian/Relation/String.hs b/debian-haskell/Debian/Relation/String.hs deleted file mode 100644 --- a/debian-haskell/Debian/Relation/String.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE FlexibleInstances, PackageImports, TypeSynonymInstances #-} -{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-orphans #-} --- |A module for working with debian relationships -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 diff --git a/debian-haskell/Debian/Relation/Text.hs b/debian-haskell/Debian/Relation/Text.hs deleted file mode 100644 --- a/debian-haskell/Debian/Relation/Text.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} --- |A module for working with debian relationships -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) diff --git a/debian-haskell/Debian/Release.hs b/debian-haskell/Debian/Release.hs deleted file mode 100644 --- a/debian-haskell/Debian/Release.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# 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) diff --git a/debian-haskell/Debian/Report.hs b/debian-haskell/Debian/Report.hs deleted file mode 100644 --- a/debian-haskell/Debian/Report.hs +++ /dev/null @@ -1,87 +0,0 @@ -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 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) ] - ] diff --git a/debian-haskell/Debian/Sources.hs b/debian-haskell/Debian/Sources.hs deleted file mode 100644 --- a/debian-haskell/Debian/Sources.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# 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 (" [\"" :: String)) 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 diff --git a/debian-haskell/Debian/Time.hs b/debian-haskell/Debian/Time.hs deleted file mode 100644 --- a/debian-haskell/Debian/Time.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE CPP #-} -module Debian.Time where - -import Data.Time -#if !MIN_VERSION_time(1,5,0) -import System.Locale (defaultTimeLocale) -#endif -import Data.Time.Clock.POSIX -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' - diff --git a/debian-haskell/Debian/URI.hs b/debian-haskell/Debian/URI.hs deleted file mode 100644 --- a/debian-haskell/Debian/URI.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# 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 "( 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 diff --git a/debian-haskell/Debian/UTF8.hs b/debian-haskell/Debian/UTF8.hs deleted file mode 100644 --- a/debian-haskell/Debian/UTF8.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE CPP #-} --- | 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 - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -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 diff --git a/debian-haskell/Debian/Util/FakeChanges.hs b/debian-haskell/Debian/Util/FakeChanges.hs deleted file mode 100644 --- a/debian-haskell/Debian/Util/FakeChanges.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# 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 diff --git a/debian-haskell/Debian/Version.hs b/debian-haskell/Debian/Version.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version.hs +++ /dev/null @@ -1,16 +0,0 @@ --- |A module for parsing, comparing, and (eventually) modifying debian version --- numbers. -module Debian.Version - (DebianVersion -- |Exported abstract because the internal representation is likely to change - , prettyDebianVersion - , parseDebianVersion - , parseDebianVersion' - , epoch - , version - , revision - , buildDebianVersion - , evr - ) where - -import Debian.Version.Common -import Debian.Version.String () diff --git a/debian-haskell/Debian/Version/ByteString.hs b/debian-haskell/Debian/Version/ByteString.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version/ByteString.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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 -> Left e - Right dv -> Right (DebianVersion str dv) diff --git a/debian-haskell/Debian/Version/Common.hs b/debian-haskell/Debian/Version/Common.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version/Common.hs +++ /dev/null @@ -1,185 +0,0 @@ --- |A module for parsing, comparing, and (eventually) modifying debian version --- numbers. -{-# 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(..) - , 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-> Either ParseError 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? - -parseDebianVersion' :: ParseDebianVersion string => string -> DebianVersion -parseDebianVersion' str = either (\e -> error (show e)) id (parseDebianVersion str) - -{- -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) diff --git a/debian-haskell/Debian/Version/Internal.hs b/debian-haskell/Debian/Version/Internal.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version/Internal.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} -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) diff --git a/debian-haskell/Debian/Version/String.hs b/debian-haskell/Debian/Version/String.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version/String.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# 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 -> Left e - Right dv -> Right (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 -> [] diff --git a/debian-haskell/Debian/Version/Text.hs b/debian-haskell/Debian/Version/Text.hs deleted file mode 100644 --- a/debian-haskell/Debian/Version/Text.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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 -> Left e - Right dv -> Right (DebianVersion str dv) diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,23 @@ +haskell-cabal-debian (4.31.9) unstable; urgency=low + + * Fix official haskell packages repository URI + * Update expected test results + + -- David Fox Mon, 21 Dec 2015 09:14:14 -0800 + +haskell-cabal-debian (4.31.8) unstable; urgency=low + + * Handle some idempotent cases in mapCabal and splitCabal + * Add version split for happstack-authenticate package + + -- David Fox Thu, 08 Oct 2015 11:42:13 -0400 + +haskell-cabal-debian (4.31.7) unstable; urgency=low + + * Allow optparse-applicative-0.12. + + -- David Fox Fri, 25 Sep 2015 11:18:00 -0700 + haskell-cabal-debian (4.31.6) unstable; urgency=low * Signature change in Debian.Version.parseDebianVersion diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -7,8 +7,9 @@ cdbs, ghc, ghc-prof, - libghc-cabal-dev (>= 1.18) | ghc, - libghc-cabal-prof (>= 1.18) | ghc-prof, + libghc-cabal-dev (>= 1.16), + libghc-cabal-dev (>= 1.18), + libghc-cabal-prof (>= 1.18), libghc-diff-dev (>= 0.3.1), libghc-diff-prof (>= 0.3.1), libghc-hunit-dev, @@ -112,7 +113,7 @@ Depends: ${haskell:Depends}, ${misc:Depends}, ${shlibs:Depends}, - debian-policy + debian-policy, Recommends: ${haskell:Recommends}, Suggests: ${haskell:Suggests}, Conflicts: ${haskell:Conflicts}, diff --git a/src/Debian/Debianize/DebianName.hs b/src/Debian/Debianize/DebianName.hs --- a/src/Debian/Debianize/DebianName.hs +++ b/src/Debian/Debianize/DebianName.hs @@ -21,7 +21,7 @@ import Debian.Debianize.CabalInfo as A (debianNameMap, packageDescription, debInfo) import Debian.Debianize.BinaryDebDescription as Debian (PackageType(..)) import Debian.Debianize.DebInfo as D (overrideDebianNameBase, utilsPackageNameBase) -import Debian.Debianize.VersionSplits (DebBase(DebBase, unDebBase), doSplits, insertSplit, makePackage, VersionSplits) +import Debian.Debianize.VersionSplits (DebBase(DebBase, unDebBase), doSplits, insertSplit, makePackage, VersionSplits(oldestPackage, splits)) import Debian.Orphans () import Debian.Relation (PkgName(..), Relations) import qualified Debian.Relation as D (VersionReq(EEQ)) @@ -107,6 +107,7 @@ where f :: Maybe VersionSplits -> Maybe VersionSplits f Nothing = Just (makePackage dname) + f (Just sp) | any (== dname) (oldestPackage sp : map snd (splits sp)) = Just sp f (Just sp) = error $ "mapCabal " ++ show pname ++ " " ++ show dname ++ ": - already mapped: " ++ show sp -- | Map versions less than ver of Cabal Package pname to Debian package ltname diff --git a/src/Debian/Debianize/Details.hs b/src/Debian/Debianize/Details.hs --- a/src/Debian/Debianize/Details.hs +++ b/src/Debian/Debianize/Details.hs @@ -27,7 +27,7 @@ A.epochMap %= Map.insert (PackageName "HTTP") 1 -- Associate some build tools and their corresponding -- (eponymous) debian package names - mapM (\name -> (A.debInfo . D.execMap) %= Map.insert name [[Rel (BinPkgName name) Nothing Nothing]]) + mapM_ (\name -> (A.debInfo . D.execMap) %= Map.insert name [[Rel (BinPkgName name) Nothing Nothing]]) ["ghc", "happy", "alex", "hsx2hs"] -- The parsec debs are suffixed with either "2" or "3" mapCabal (PackageName "parsec") (DebBase "parsec3") @@ -42,3 +42,6 @@ mapCabal (PackageName "haskell-src-exts") (DebBase "src-exts") mapCabal (PackageName "haskell-src-meta") (DebBase "src-meta") mapCabal (PackageName "Cabal") (DebBase "cabal") + + mapCabal (PackageName "happstack-authenticate") (DebBase "happstack-authenticate") + splitCabal (PackageName "happstack-authenticate") (DebBase "happstack-authenticate-0") (Version [2] []) diff --git a/src/Debian/Debianize/Finalize.hs b/src/Debian/Debianize/Finalize.hs --- a/src/Debian/Debianize/Finalize.hs +++ b/src/Debian/Debianize/Finalize.hs @@ -351,19 +351,23 @@ _ -> error $ "There is no official packaging for " ++ show flavor officialSettings :: (Monad m, Functor m) => CabalT m () -officialSettings = - do pkgDesc <- use A.packageDescription - let PackageName cabal = pkgName (Cabal.package pkgDesc) +officialSettings = do + pkgDesc <- use A.packageDescription + let PackageName cabal = pkgName (Cabal.package pkgDesc) + zoom A.debInfo $ do + let officialError = error "officialSettings: no sourcePackageName" - (A.debInfo . D.control . S.standardsVersion) .?= Just (parseStandardsVersion "3.9.6") - (A.debInfo . D.control . S.homepage) .?= Just ("http://hackage.haskell.org/package/" <> pack cabal) - (A.debInfo . D.omitProfVersionDeps) .= True - SrcPkgName src <- use (A.debInfo . D.sourcePackageName) >>= maybe (error "officialSettings: no sourcePackageName") return + D.omitProfVersionDeps .= True + SrcPkgName src <- fromMaybe officialError <$> use D.sourcePackageName - (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 - ]) + let packagesURI = "https://anonscm.debian.org/cgit/pkg-haskell/DHG_packages.git/tree/p/" <> pack src + zoom D.control $ do + S.standardsVersion .?= Just (parseStandardsVersion "3.9.6") + S.homepage .?= Just ("http://hackage.haskell.org/package/" <> pack cabal) + S.vcsFields %= Set.union (Set.fromList + [ S.VCSBrowser packagesURI + , S.VCSGit "git://git.debian.org/git/pkg-haskell/DHG_packages.git" + ]) putBuildDeps :: (Monad m, Functor m) => (Relations -> Relations) -> PackageDescription -> CabalT m () putBuildDeps finalizeRelations pkgDesc = diff --git a/src/Debian/Debianize/VersionSplits.hs b/src/Debian/Debianize/VersionSplits.hs --- a/src/Debian/Debianize/VersionSplits.hs +++ b/src/Debian/Debianize/VersionSplits.hs @@ -4,7 +4,7 @@ module Debian.Debianize.VersionSplits ( DebBase(DebBase, unDebBase) -- * Combinators for VersionSplits - , VersionSplits + , VersionSplits(..) , makePackage , insertSplit -- * Operators on VersionSplits @@ -43,7 +43,7 @@ -- ^ Each pair is The version where the split occurs, and the -- name to use for versions greater than or equal to that -- version. This list assumed to be in (must be kept in) - -- ascending version number order. + -- descending version number order, newest to oldest } deriving (Eq, Ord, Data, Typeable) instance Show VersionSplits where @@ -59,12 +59,16 @@ makePackage name = VersionSplits {oldestPackage = name, splits = []} -- | Split the version range and give the older packages a new name. -insertSplit :: Version -> DebBase -> VersionSplits -> VersionSplits +insertSplit :: Version -- ^ Where to split the version range + -> DebBase -- ^ The name to use for versions older than the split + -> VersionSplits + -> VersionSplits insertSplit ver@(Version _ _) ltname sp@(VersionSplits {}) = -- (\ x -> trace ("insertSplit " ++ show (ltname, ver, sp) ++ " -> " ++ show x) x) $ case splits sp of -- This is the oldest split, change oldestPackage and insert a new head pair (ver', _) : _ | ver' > ver -> sp {oldestPackage = ltname, splits = (ver, oldestPackage sp) : splits sp} + (ver', name) : _ | ver' == ver && name == ltname -> sp [] -> sp {oldestPackage = ltname, splits = [(ver, oldestPackage sp)]} -- Not the oldest split, insert it in its proper place. _ -> sp {splits = reverse (insert (reverse (splits sp)))} diff --git a/test-data/artvaluereport-data/output/debian/control b/test-data/artvaluereport-data/output/debian/control --- a/test-data/artvaluereport-data/output/debian/control +++ b/test-data/artvaluereport-data/output/debian/control @@ -62,8 +62,6 @@ , libghc-mtl-prof , libghc-network-dev (>= 2.4) , libghc-network-prof (>= 2.4) - , libghc-old-time-dev - , libghc-old-time-prof , libghc-pandoc-dev , libghc-pandoc-prof , libghc-pandoc-types-dev @@ -92,6 +90,8 @@ , libghc-text-prof , libghc-utf8-string-dev , libghc-utf8-string-prof + , libghc-xhtml-dev + , libghc-xhtml-prof Build-Depends-Indep: ghc-doc , libghc-extra-doc , libghc-hunit-doc @@ -120,7 +120,6 @@ , libghc-maccatcher-doc , libghc-mtl-doc , libghc-network-doc - , libghc-old-time-doc , libghc-pandoc-doc , libghc-pandoc-types-doc , libghc-parsec3-doc (>= 3) | libghc-parsec2-doc (<< 3) @@ -135,6 +134,7 @@ , libghc-syb-with-class-doc , libghc-text-doc , libghc-utf8-string-doc + , libghc-xhtml-doc Standards-Version: 3.9.6 Homepage: http://artvaluereportonline.com X-Description: Data structures used by the fine art appraisal application diff --git a/test-data/artvaluereport2/output/debian/control b/test-data/artvaluereport2/output/debian/control --- a/test-data/artvaluereport2/output/debian/control +++ b/test-data/artvaluereport2/output/debian/control @@ -30,7 +30,7 @@ , libghc-fb-dev , libghc-groom-dev , libghc-happstack-dev - , libghc-happstack-authenticate-dev + , libghc-happstack-authenticate-dev (>= 2) | libghc-happstack-authenticate-0-dev (<< 2), , libghc-happstack-extra-dev , libghc-happstack-hsp-dev , libghc-happstack-scaffolding-dev (>= 0.23) @@ -49,8 +49,6 @@ , libghc-lifted-base-dev , libghc-mtl-dev , libghc-network-dev (>= 2.4) - , libghc-old-locale-dev - , libghc-old-time-dev , libghc-pandoc-dev , libghc-parsec3-dev , libghc-process-extras-dev (>= 0.5) @@ -64,12 +62,14 @@ , libghc-syb-with-class-dev , libghc-tagged-dev , libghc-text-dev + , libghc-transformers-dev , libghc-uniplate-dev , libghc-utf8-string-dev , libghc-web-routes-dev , libghc-web-routes-happstack-dev , libghc-web-routes-hsp-dev , libghc-web-routes-th-dev + , libghc-xhtml-dev Standards-Version: 3.9.6 Homepage: http://appraisalreportonline.com X-Description: Haskell modules for fine art appraisal applications diff --git a/test-data/creativeprompts/output/debian/control b/test-data/creativeprompts/output/debian/control --- a/test-data/creativeprompts/output/debian/control +++ b/test-data/creativeprompts/output/debian/control @@ -22,7 +22,6 @@ , libghc-digestive-functors-dev (>= 0.2) , libghc-digestive-functors-happstack-dev (>= 0.1) , libghc-digestive-functors-hsp-dev (>= 0.3.1) - , libghc-extensible-exceptions-dev , libghc-happstack-authenticate-dev (>= 0.6) , libghc-happstack-hsp-dev (>= 7.1) , libghc-happstack-hsp-dev (<< 7.2) @@ -38,8 +37,6 @@ , libghc-json-dev , libghc-mtl-dev , libghc-network-dev - , libghc-old-locale-dev - , libghc-old-time-dev , libghc-parsec3-dev (>= 3) | libghc-parsec2-dev (<< 3) , libghc-random-dev , libghc-safecopy-dev (>= 0.6.0)