cabal-debian-3.9/0000755000175000017500000000000012236246354011770 5ustar dsfdsfcabal-debian-3.9/cabal-debian.cabal0000644000175000017500000000600612236246354015240 0ustar dsfdsfName: cabal-debian Version: 3.9 License: BSD3 License-File: debian/copyright Author: David Fox Category: Debian, Distribution, System Maintainer: David Fox Homepage: http://src.seereason.com/debian-tools/cabal-debian Build-Type: Simple Synopsis: Create a debianization for a cabal package Cabal-Version: >= 1.8 Extra-Source-Files: changelog, debian/Debianize.hs Description: This package provides two methods for generating the debianization (i.e. the contents of the 'debian' subdirectory) for a cabal package. An executable named cabal-debian, and a library API to handle more complex packaging issues. For documentation of the executable run @cabal-debian --help@, for documentation of the library API follow the link to the @Debian.Debianize@ module below. Flag tests Description: enable the unit test executable (disabled by default because it has a lot of wacky dependencies.) Default: False Manual: True Source-Repository head type: darcs location: http://src.seereason.com/debian-tools Library Hs-Source-Dirs: src GHC-Options: -Wall -O2 Build-Depends: ansi-wl-pprint, base < 5, Cabal >= 1.9, containers, data-lens, debian >= 3.71, Diff, directory, filepath, hsemail, HUnit, mtl, parsec >= 3, process, pureMD5, regex-tdfa, syb, text, unix, utf8-string Exposed-Modules: Data.Algorithm.Diff.Context Data.Algorithm.Diff.Pretty Debian.Debianize Debian.Debianize.Atoms Debian.Debianize.Bundled Debian.Debianize.ControlFile Debian.Debianize.Debianize Debian.Debianize.Dependencies Debian.Debianize.Details Debian.Debianize.Files Debian.Debianize.Finalize Debian.Debianize.Goodies Debian.Debianize.Interspersed Debian.Debianize.Input Debian.Debianize.Options Debian.Debianize.SubstVars Debian.Debianize.Types Debian.Debianize.Types.VersionSplits Debian.Debianize.Utility Debian.Debianize.VersionSplits Debian.Orphans Debian.Policy Distribution.Version.Invert Executable cabal-debian Main-is: src/CabalDebian.hs ghc-options: -threaded -Wall -O2 Build-Depends: base, Cabal, cabal-debian, containers, data-lens Executable cabal-debian-tests Main-is: src/Debian/Debianize/Tests.hs ghc-options: -threaded -Wall -O2 Build-Depends: ansi-wl-pprint, base, Cabal, cabal-debian, containers, data-lens, debian, filepath, hsemail, HUnit, mtl, parsec >= 3, process, pureMD5, regex-tdfa, syb, text, unix, utf8-string -- Executable cabal-debian-tests -- Main-Is: src/Tests.hs -- GHC-Options: -Wall -O2 -threaded -rtsopts -- Build-Depends: -- ansi-wl-pprint, -- base, -- Cabal, -- cabal-debian, -- containers, -- data-lens, -- debian, -- Diff, -- directory, -- filepath, -- hsemail, -- HUnit, -- mtl, -- parsec, -- process, -- pureMD5, -- regex-tdfa, -- syb, -- text, -- unix, -- utf8-string cabal-debian-3.9/changelog0000644000175000017500000005626212236246354013655 0ustar dsfdsfhaskell-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 cabal-debian-3.9/Setup.hs0000644000175000017500000000124712236246354013430 0ustar dsfdsf#!/usr/bin/runhaskell import Control.Monad (when) import Distribution.Simple import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) import Distribution.Simple.Program import System.Cmd import System.Directory import System.Exit main = copyFile "debian/changelog" "changelog" >> defaultMainWithHooks simpleUserHooks {- { postBuild = \ _ _ _ lbi -> when (buildDir lbi /= "dist-ghc/build") (runTestScript lbi) , runTests = \ _ _ _ lbi -> runTestScript lbi } -} runTestScript lbi = system (buildDir lbi ++ "/cabal-debian-tests/cabal-debian-tests") >>= \ code -> if code == ExitSuccess then return () else error "unit test failure" cabal-debian-3.9/src/0000755000175000017500000000000012236246354012557 5ustar dsfdsfcabal-debian-3.9/src/Data/0000755000175000017500000000000012236246354013430 5ustar dsfdsfcabal-debian-3.9/src/Data/Algorithm/0000755000175000017500000000000012236246354015356 5ustar dsfdsfcabal-debian-3.9/src/Data/Algorithm/Diff/0000755000175000017500000000000012236246354016226 5ustar dsfdsfcabal-debian-3.9/src/Data/Algorithm/Diff/Context.hs0000644000175000017500000000502712236246354020212 0ustar dsfdsfmodule Data.Algorithm.Diff.Context ( contextDiff , groups ) where import Data.Algorithm.Diff (Diff(..), getGroupedDiff) -- | Do a grouped diff and then turn it into a list of hunks, where -- each hunk is a grouped diff with at most N elements of common -- context around each one. contextDiff :: Eq a => Int -> [a] -> [a] -> [[Diff [a]]] contextDiff context a b = group $ swap $ trimTail $ trimHead $ concatMap split $ getGroupedDiff a b where -- Split common runs longer than 2N elements, keeping first and -- last N lines. split (Both xs ys) = case length xs of n | n > (2 * context) -> [Both (take context xs) (take context ys), Both (drop (n - context) xs) (drop (n - context) ys)] _ -> [Both xs ys] split x = [x] -- If split created a a pair of Both's at the beginning or end -- of the diff, remove the outermost. trimHead [] = [] trimHead [Both _ _] = [] trimHead [Both _ _, Both _ _] = [] trimHead (Both _ _ : x@(Both _ _) : more) = x : more trimHead xs = trimTail xs trimTail [x@(Both _ _), Both _ _] = [x] trimTail (x : more) = x : trimTail more trimTail [] = [] -- If we see Second before First swap them so that the deletions -- appear before the additions. swap (x@(Second _) : y@(First _) : xs) = y : x : swap xs swap (x : xs) = x : swap xs swap [] = [] -- Split the list wherever we see adjacent Both constructors group xs = groups (\ x y -> not (isBoth x && isBoth y)) xs where isBoth (Both _ _) = True isBoth _ = False -- | Group the elements whose adjacent pairs satisfy the predicate. -- Differs from groupBy because the predicate does not have to define -- a total ordering. groups :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] groups f xs = filter (/= []) $ reverse (groups' [[]] xs) where -- Predicate satisfied, add x to the current group r and recurse with y at head groups' (r : rs) (x : y : xs') | f x y = groups' ((x : r) : rs) (y : xs') -- Predicate not satisfied, add x to current group and start a new group containing y groups' (r : rs) (x : y : xs') = groups' ([y] : reverse (x : r) : rs) xs' -- Last element, add it to the current group groups' (r : rs) [y] = reverse (y : r) : rs -- Nothing left, return result groups' rs [] = rs -- This won't happen, groups' is always called with a non-empty list in the first argument groups' [] (_ : _) = error "groups" cabal-debian-3.9/src/Data/Algorithm/Diff/Pretty.hs0000644000175000017500000000161012236246354020047 0ustar dsfdsfmodule Data.Algorithm.Diff.Pretty ( prettyDiff ) where import Data.Algorithm.Diff (Diff(..)) import Data.Monoid (mconcat, (<>)) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), Doc, text, empty) -- | Format the output of 'contextDiff' to look approximately like the -- output of the unix diff command. prettyDiff :: (Pretty a, Pretty b, Pretty c) => a -> b -> [[Diff [c]]] -> Doc prettyDiff _ _ [] = empty prettyDiff old new hunks = text "--- " <> pretty old <> text "\n+++ " <> pretty new <> text "\n" <> mconcat (map (\ hunk -> text "@@\n" <> p hunk) hunks) where p (Both ts _ : more) = mconcat (map (\ l -> text " " <> pretty l <> text "\n") ts) <> p more p (First ts : more) = mconcat (map (\ l -> text "-" <> pretty l <> text "\n") ts) <> p more p (Second ts : more) = mconcat (map (\ l -> text "+" <> pretty l <> text "\n") ts) <> p more p [] = empty cabal-debian-3.9/src/Debian/0000755000175000017500000000000012236246354013741 5ustar dsfdsfcabal-debian-3.9/src/Debian/Orphans.hs0000644000175000017500000001223212236246354015707 0ustar dsfdsf{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.Orphans where import Data.Function (on) import Data.Generics (Data, Typeable) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Version (Version(..), showVersion) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) import Debian.Control (Field'(..)) import Debian.Relation (Relation(..), VersionReq(..), ArchitectureReq(..), BinPkgName(..), SrcPkgName(..)) import Debian.Version (DebianVersion) import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) import Distribution.License (License(..)) import Distribution.PackageDescription (PackageDescription(package), Executable(..)) import Distribution.Simple.Compiler (Compiler(..)) import Distribution.Version (VersionRange(..), foldVersionRange') import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..)) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) deriving instance Typeable Compiler deriving instance Typeable CompilerId deriving instance Typeable CompilerFlavor deriving instance Typeable Language deriving instance Typeable Extension deriving instance Typeable KnownExtension deriving instance Data Extension deriving instance Data KnownExtension deriving instance Data Language deriving instance Data Compiler deriving instance Data CompilerId deriving instance Data CompilerFlavor deriving instance Ord Language deriving instance Ord KnownExtension deriving instance Ord Extension deriving instance Eq Compiler deriving instance Ord Compiler deriving instance Ord NameAddr deriving instance Ord License instance Ord Executable where compare = compare `on` exeName instance Ord PackageDescription where compare = compare `on` package instance Pretty Text where pretty = text . unpack {- instance Show (Control' String) where show _ = "" instance Show ChangeLog where show _ = "" -} deriving instance Read ArchitectureReq deriving instance Read BinPkgName deriving instance Read ChangeLog deriving instance Read ChangeLogEntry deriving instance Read Relation deriving instance Read SrcPkgName deriving instance Read VersionReq deriving instance Show ChangeLog deriving instance Show ChangeLogEntry dropPrefix :: String -> String -> Maybe String dropPrefix p s = if isPrefixOf p s then Just (drop (length p) s) else Nothing deriving instance Data ArchitectureReq deriving instance Data BinPkgName deriving instance Data ChangeLog deriving instance Data ChangeLogEntry -- deriving instance Data NameAddr deriving instance Data Relation deriving instance Data SrcPkgName deriving instance Data VersionReq deriving instance Typeable ArchitectureReq deriving instance Typeable BinPkgName deriving instance Typeable ChangeLog deriving instance Typeable ChangeLogEntry -- deriving instance Typeable NameAddr deriving instance Typeable Relation deriving instance Typeable SrcPkgName deriving instance Typeable VersionReq deriving instance Ord ChangeLog deriving instance Ord ChangeLogEntry {- instance Pretty SrcPkgName where pretty (SrcPkgName x) = pretty x instance Pretty BinPkgName where pretty (BinPkgName x) = pretty x -} deriving instance Typeable License deriving instance Data Version deriving instance Data License -- Convert from license to RPM-friendly description. The strings are -- taken from TagsCheck.py in the rpmlint distribution. instance Pretty License where pretty (GPL _) = text "GPL" pretty (LGPL _) = text "LGPL" pretty BSD3 = text "BSD" pretty BSD4 = text "BSD-like" pretty PublicDomain = text "Public Domain" pretty AllRightsReserved = text "Proprietary" pretty OtherLicense = text "Non-distributable" pretty MIT = text "MIT" pretty (UnknownLicense _) = text "Unknown" pretty x = text (show x) deriving instance Data NameAddr deriving instance Typeable NameAddr deriving instance Read NameAddr -- This Pretty instance gives a string used to create a valid -- changelog entry, it *must* have a name followed by an email address -- in angle brackets. instance Pretty NameAddr where pretty x = text (fromMaybe (nameAddr_addr x) (nameAddr_name x) ++ " <" ++ nameAddr_addr x ++ ">") -- pretty x = text (maybe (nameAddr_addr x) (\ n -> n ++ " <" ++ nameAddr_addr x ++ ">") (nameAddr_name x)) deriving instance Show (Field' String) instance Pretty VersionRange where pretty range = foldVersionRange' (text "*") (\ v -> text "=" <> pretty v) (\ v -> text ">" <> pretty v) (\ v -> text "<" <> pretty v) (\ v -> text ">=" <> pretty v) (\ v -> text "<=" <> pretty v) (\ x _ -> text "=" <> pretty x <> text ".*") -- not exactly right (\ x y -> text "(" <> x <> text " || " <> y <> text ")") (\ x y -> text "(" <> x <> text " && " <> y <> text ")") (\ x -> text "(" <> x <> text ")") range instance Pretty Version where pretty = text . showVersion instance Pretty DebianVersion where pretty = text . show cabal-debian-3.9/src/Debian/Debianize.hs0000644000175000017500000000567012236246354016177 0ustar dsfdsf-- | QUICK START: You can either run the @cabal-debian --debianize@, or -- for more power and flexibility you can put a @Debianize.hs@ script in -- the package's @debian@ subdirectory. -- 'Debian.Debianize.Atoms' value and pass it to the -- 'Debian.Debianize.debianize' function. The -- 'Debian.Debianize.callDebianize' function retrieves extra arguments -- from the @CABALDEBIAN@ environment variable and calls -- 'Debian.Debianize.debianize' with the build directory set as it -- would be when the packages is built by @dpkg-buildpackage@. -- -- To see what your debianization would produce, or how it differs -- from the debianization already present: -- -- > % cabal-debian --debianize -n -- -- This is equivalent to the library call -- -- > % ghc -e 'Debian.Debianize.callDebianize ["-n"]' -- -- To actually create the debianization and then build the debs, -- -- > % ghc -e 'Debian.Debianize.callDebianize []' -- > % sudo dpkg-buildpackage -- -- At this point you may need to modify Cabal.defaultFlags to achieve -- specific packaging goals. Create a module for this in debian/Debianize.hs: -- -- > import Data.Lens.Lazy -- > import Data.Map as Map (insertWith) -- > import Data.Set as Set (union, singleton) -- > import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel)) -- > import Debian.Debianize (defaultAtoms, depends, debianization, writeDebianization) -- > main = debianization "." defaultAtoms >>= -- > return . modL depends (insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) >>= -- > writeDebianization "." -- -- Then to test it, -- -- > % CABALDEBIAN='["-n"]' runhaskell debian/Debianize.hs -- -- or equivalently -- -- > % ghc -e 'Debian.Debianize.runDebianize ["-n"]' -- -- and to run it for real: -- -- > % runhaskell debian/Debianize.hs module Debian.Debianize ( module Debian.Debianize.Atoms , module Debian.Debianize.Bundled , module Debian.Debianize.ControlFile , module Debian.Debianize.Debianize , module Debian.Debianize.Dependencies , module Debian.Debianize.Files , module Debian.Debianize.Finalize , module Debian.Debianize.Goodies , module Debian.Debianize.Input , module Debian.Debianize.Interspersed , module Debian.Debianize.Options , module Debian.Debianize.SubstVars , module Debian.Debianize.Types , module Debian.Debianize.Utility , module Debian.Policy ) where import Debian.Debianize.Atoms import Debian.Debianize.Bundled import Debian.Debianize.Debianize import Debian.Debianize.Dependencies import Debian.Debianize.Files import Debian.Debianize.Finalize import Debian.Debianize.Goodies import Debian.Debianize.Input import Debian.Debianize.Interspersed import Debian.Debianize.Options import Debian.Debianize.SubstVars import Debian.Debianize.Types import Debian.Debianize.ControlFile hiding (depends, conflicts, maintainer, description, section) import Debian.Debianize.Utility import Debian.Policy cabal-debian-3.9/src/Debian/Policy.hs0000644000175000017500000002356512236246354015547 0ustar dsfdsf-- | Code pulled out of cabal-debian that straightforwardly implements -- parts of the Debian policy manual, or other bits of Linux standards. {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Debian.Policy ( -- * Paths databaseDirectory , apacheLogDirectory , apacheErrorLog , apacheAccessLog , serverLogDirectory , serverAppLog , serverAccessLog , errorLogBaseName , appLogBaseName , accessLogBaseName -- * Installed packages , debianPackageVersion , getDebhelperCompatLevel , StandardsVersion(..) , getDebianStandardsVersion , parseStandardsVersion -- * Package fields , SourceFormat(..) , readSourceFormat , PackagePriority(..) , readPriority , PackageArchitectures(..) , parsePackageArchitectures , Section(..) , readSection , Area(..) , parseUploaders , parseMaintainer , getDebianMaintainer , haskellMaintainer ) where import Codec.Binary.UTF8.String (decodeString) import Control.Arrow (second) import Control.Monad (mplus) import Data.Char (toLower, isSpace) import Data.List (groupBy, intercalate) import Data.Generics (Data, Typeable) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack, strip) import Debian.Debianize.Utility (read') import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion, parseDebianVersion, version) import System.Environment (getEnvironment) import System.FilePath (()) import System.Process (readProcess) import Text.Parsec (parse) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..), address) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty), text) databaseDirectory :: BinPkgName -> String databaseDirectory x = "/srv" show (pretty x) apacheLogDirectory :: BinPkgName -> String apacheLogDirectory x = "/var/log/apache2/" ++ show (pretty x) apacheErrorLog :: BinPkgName -> String apacheErrorLog x = apacheLogDirectory x errorLogBaseName apacheAccessLog :: BinPkgName -> String apacheAccessLog x = apacheLogDirectory x accessLogBaseName serverLogDirectory :: BinPkgName -> String serverLogDirectory x = "/var/log/" ++ show (pretty x) serverAppLog :: BinPkgName -> String serverAppLog x = serverLogDirectory x appLogBaseName serverAccessLog :: BinPkgName -> String serverAccessLog x = serverLogDirectory x accessLogBaseName appLogBaseName :: String appLogBaseName = "app.log" errorLogBaseName :: String errorLogBaseName = "error.log" accessLogBaseName :: String accessLogBaseName = "access.log" debianPackageVersion :: String -> IO (Maybe DebianVersion) debianPackageVersion name = readProcess "dpkg-query" ["--show", "--showformat=${version}", name] "" >>= return . parseDebianVersion' where -- This should maybe be the real parseDebianVersion parseDebianVersion' "" = Nothing parseDebianVersion' s = Just (parseDebianVersion s) -- | Assumes debhelper is installed getDebhelperCompatLevel :: IO (Maybe Int) getDebhelperCompatLevel = debianPackageVersion "debhelper" >>= return . fmap (read . takeWhile (/= '.') . version) data StandardsVersion = StandardsVersion Int Int Int (Maybe Int) deriving (Eq, Ord, Show, Data, Typeable) instance Pretty StandardsVersion where pretty (StandardsVersion a b c (Just d)) = text $ show a <> "." <> show b <> "." <> show c <> "." <> show d pretty (StandardsVersion a b c Nothing) = text $ show a <> "." <> show b <> "." <> show c -- | Assumes debian-policy is installed getDebianStandardsVersion :: IO (Maybe StandardsVersion) getDebianStandardsVersion = debianPackageVersion "debian-policy" >>= return . fmap (parseStandardsVersion . version) parseStandardsVersion :: String -> StandardsVersion parseStandardsVersion s = case filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) s) of (a : b : c : d : _) -> StandardsVersion (read' (error . ("StandardsVersion" ++) . show) a) (read' (error . ("StandardsVersion" ++) . show) b) (read' (error . ("StandardsVersion" ++) . show) c) (Just (read' (error . ("StandardsVersion" ++) . show) d)) (a : b : c : _) -> StandardsVersion (read' (error . ("StandardsVersion" ++) . show) a) (read' (error . ("StandardsVersion" ++) . show) b) (read' (error . ("StandardsVersion" ++) . show) c) Nothing _ -> error $ "Invalid Standards-Version string: " ++ show s data SourceFormat = Native3 | Quilt3 deriving (Eq, Ord, Show, Data, Typeable) instance Pretty SourceFormat where pretty Quilt3 = text "3.0 (quilt)\n" pretty Native3 = text "3.0 (native)\n" readSourceFormat :: Text -> Either Text SourceFormat readSourceFormat s = case () of _ | strip s == "3.0 (native)" -> Right Native3 _ | strip s == "3.0 (quilt)" -> Right Quilt3 _ -> Left $ "Invalid debian/source/format: " <> pack (show (strip s)) data PackagePriority = Required | Important | Standard | Optional | Extra deriving (Eq, Ord, Read, Show, Data, Typeable) readPriority :: String -> PackagePriority readPriority s = case unpack (strip (pack s)) of "required" -> Required "important" -> Important "standard" -> Standard "optional" -> Optional "extra" -> Extra x -> error $ "Invalid priority string: " ++ show x instance Pretty PackagePriority where pretty = text . map toLower . show -- | The architectures for which a binary deb can be built. data PackageArchitectures = All -- ^ The package is architecture independenct | Any -- ^ The package can be built for any architecture | Names [String] -- ^ The list of suitable architectures deriving (Read, Eq, Ord, Show, Data, Typeable) instance Pretty PackageArchitectures where pretty All = text "all" pretty Any = text "any" pretty (Names xs) = text $ intercalate " " xs parsePackageArchitectures :: String -> PackageArchitectures parsePackageArchitectures "all" = All parsePackageArchitectures "any" = Any parsePackageArchitectures s = error $ "FIXME: parsePackageArchitectures " ++ show s data Section = MainSection String -- Equivalent to AreaSection Main s? | AreaSection Area String deriving (Read, Eq, Ord, Show, Data, Typeable) readSection :: String -> Section readSection s = case break (== '/') s of ("contrib", '/' : b) -> AreaSection Contrib (tail b) ("non-free", '/' : b) -> AreaSection NonFree (tail b) ("main", '/' : b) -> AreaSection Main (tail b) (a, '/' : _) -> error $ "readSection - unknown area: " ++ show a (a, _) -> MainSection a instance Pretty Section where pretty (MainSection sec) = text sec pretty (AreaSection area sec) = pretty area <> text ("/" <> sec) -- Is this really all that is allowed here? Doesn't Ubuntu have different areas? data Area = Main | Contrib | NonFree deriving (Read, Eq, Ord, Show, Data, Typeable) instance Pretty Area where pretty Main = text "main" pretty Contrib = text "contrib" pretty NonFree = text "non-free" {- Create a debian maintainer field from the environment variables: DEBFULLNAME (preferred) or NAME DEBEMAIL (preferred) or EMAIL More work could be done to match dch, but this is sufficient for now. Here is what the man page for dch has to say: If the environment variable DEBFULLNAME is set, this will be used for the maintainer full name; if not, then NAME will be checked. If the environment variable DEBEMAIL is set, this will be used for the email address. If this variable has the form "name ", then the maintainer name will also be taken from here if neither DEBFULLNAME nor NAME is set. If this variable is not set, the same test is performed on the environment variable EMAIL. Next, if the full name has still not been determined, then use getpwuid(3) to determine the name from the pass‐word file. If this fails, use the previous changelog entry. For the email address, if it has not been set from DEBEMAIL or EMAIL, then look in /etc/mailname, then attempt to build it from the username and FQDN, otherwise use the email address in the previous changelog entry. In other words, it’s a good idea to set DEBEMAIL and DEBFULLNAME when using this script. -} getDebianMaintainer :: IO (Maybe NameAddr) getDebianMaintainer = do env <- map (second decodeString) `fmap` getEnvironment return $ do fullname <- lookup "DEBFULLNAME" env `mplus` lookup "NAME" env email <- lookup "DEBEMAIL" env `mplus` lookup "EMAIL" env either (const Nothing) Just (parseMaintainer (fullname ++ " <" ++ email ++ ">")) haskellMaintainer :: NameAddr haskellMaintainer = NameAddr { nameAddr_name = Just "Debian Haskell Group" , nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"} parseUploaders :: String -> Either String [NameAddr] parseUploaders x = either (Left . show) fixNameAddrs (parse address "" ("Names: " ++ map fixWhite x ++ ";")) -- either (\ e -> error ("Failure parsing uploader list: " ++ show x ++ " -> " ++ show e)) id $ where fixWhite c = if isSpace c then ' ' else c -- We absoletely need a name. fixNameAddrs :: [NameAddr] -> Either String [NameAddr] fixNameAddrs xs = case mapMaybe fixNameAddr xs of [] -> Left ("No valid debian maintainers in " ++ show x) xs' -> Right xs' fixNameAddr :: NameAddr -> Maybe NameAddr fixNameAddr y = case nameAddr_name y of Nothing -> Nothing _ -> Just y parseMaintainer :: String -> Either String NameAddr parseMaintainer x = case parseUploaders x of Left s -> Left s Right [y] -> Right y Right [] -> Left $ "Missing maintainer: " ++ show x Right ys -> Left $ "Too many maintainers: " ++ show ys cabal-debian-3.9/src/Debian/Debianize/0000755000175000017500000000000012236246354015633 5ustar dsfdsfcabal-debian-3.9/src/Debian/Debianize/Tests.hs0000644000175000017500000010526112236246354017276 0ustar dsfdsf{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Main ( tests , main ) where import Data.Algorithm.Diff.Context (contextDiff) import Data.Algorithm.Diff.Pretty (prettyDiff) import Data.Function (on) import Data.Lens.Lazy (setL, getL, modL) import Data.List (sortBy) import Data.Map as Map (differenceWithKey, intersectionWithKey) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid (mconcat, (<>), mempty) import Data.Set as Set (fromList, union, insert, singleton) import qualified Data.Text as T import Data.Version (Version(Version)) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry) import Debian.Debianize.Debianize (debianization) import Debian.Debianize.Atoms as Atoms (Atoms, rulesHead, compat, sourceFormat, changelog, control, missingDependencies, revision, binaryArchitectures, copyright, debVersion, execMap, buildDeps, utilsPackageNames, description, depends, installData, epochMap {-, sourcePackageName, install, buildDepsIndep-}) import Debian.Debianize.ControlFile as Deb (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..)) import Debian.Debianize.Dependencies (getRulesHead) import Debian.Debianize.Files (toFileMap) import Debian.Debianize.Finalize (finalizeDebianization) import Debian.Debianize.Goodies (tightDependencyFixup, doExecutable, doWebsite, doServer, doBackups) import Debian.Debianize.Input (inputChangeLog, inputDebianization, inputCabalization) import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..), Top(Top)) import Debian.Debianize.VersionSplits (mapCabal, splitCabal) import Debian.Policy (databaseDirectory, StandardsVersion(StandardsVersion), getDebhelperCompatLevel, getDebianStandardsVersion, PackagePriority(Extra), PackageArchitectures(All), SourceFormat(Native3), Section(..), parseMaintainer) import Debian.Relation (Relation(..), VersionReq(..), SrcPkgName(..), BinPkgName(..)) import Debian.Release (ReleaseName(ReleaseName, relName)) import Debian.Version (buildDebianVersion, parseDebianVersion) import Distribution.License (License(BSD3)) import Distribution.Package (PackageName(PackageName)) import Prelude hiding (log) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath (()) import System.Process (readProcessWithExitCode) import Test.HUnit import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) import Text.PrettyPrint.ANSI.Leijen (Pretty, pretty, text) -- | A suitable defaultAtoms value for the debian repository. defaultAtoms :: Atoms defaultAtoms = setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . mapCabal (PackageName "parsec") "parsec3" . splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . mapCabal (PackageName "QuickCheck") "quickcheck2" . mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ mempty -- | Create a Debianization based on a changelog entry and a license -- value. Uses the currently installed versions of debhelper and -- debian-policy to set the compatibility levels. newDebianization :: ChangeLog -> Maybe Int -> Maybe StandardsVersion -> Atoms newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry" newDebianization (log@(ChangeLog (entry : _))) level standards = setL changelog (Just log) $ setL compat level $ modL control (\ x -> x { source = Just (SrcPkgName (logPackage entry)) , maintainer = (either error Just (parseMaintainer (logWho entry))) , standardsVersion = standards }) $ defaultAtoms newDebianization _ _ _ = error "Invalid changelog" newDebianization' :: Maybe Int -> Maybe StandardsVersion -> Atoms -> Atoms newDebianization' level standards atoms = setL compat level . modL control (\ x -> x { standardsVersion = standards }) $ atoms tests :: Test tests = TestLabel "Debianization Tests" (TestList [test1, test2, test3, test4, test5, test6, test7, test8, test9]) test1 :: Test test1 = TestLabel "test1" $ TestCase (do level <- getDebhelperCompatLevel standards <- getDebianStandardsVersion :: IO (Maybe StandardsVersion) let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ newDebianization (ChangeLog [testEntry]) level standards assertEqual "test1" [] (diffDebianizations testDeb1 deb)) where testDeb1 :: Atoms testDeb1 = setL rulesHead (Just . T.unlines $ [ "#!/usr/bin/make -f" , "" , "include /usr/share/cdbs/1/rules/debhelper.mk" , "include /usr/share/cdbs/1/class/hlibrary.mk" ]) $ setL compat (Just 9) $ -- This will change as new version of debhelper are released setL copyright (Just (Left BSD3)) $ modL control (\ y -> y { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}) , maintainer = Just (NameAddr (Just "David Fox") "dsf@seereason.com") , standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)) -- This will change as new versions of debian-policy are released , buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing], [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing], [Rel (BinPkgName "cdbs") Nothing Nothing], [Rel (BinPkgName "ghc") Nothing Nothing], [Rel (BinPkgName "ghc-prof") Nothing Nothing]] , buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]] }) $ (newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))) log = ChangeLog [Entry { logPackage = "haskell-cabal-debian" , logVersion = buildDebianVersion Nothing "2.6.2" Nothing , logDists = [ReleaseName {relName = "unstable"}] , logUrgency = "low" , logComments = " * Fix a bug constructing the destination pathnames that was dropping\n files that were supposed to be installed into packages.\n" , logWho = "David Fox " , logDate = "Thu, 20 Dec 2012 06:49:25 -0800" }] test2 :: Test test2 = TestLabel "test2" $ TestCase (do level <- getDebhelperCompatLevel standards <- getDebianStandardsVersion let deb = finalizeDebianization $ setL copyright (Just (Left BSD3)) $ newDebianization (ChangeLog [testEntry]) level standards assertEqual "test2" [] (diffDebianizations expect deb)) where expect = setL rulesHead (Just . T.unlines $ ["#!/usr/bin/make -f", "", "include /usr/share/cdbs/1/rules/debhelper.mk", "include /usr/share/cdbs/1/class/hlibrary.mk"]) $ setL compat (Just 9) $ setL copyright (Just (Left BSD3)) $ modL control (\ y -> y { source = Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"}), maintainer = Just (NameAddr {nameAddr_name = Just "David Fox", nameAddr_addr = "dsf@seereason.com"}), standardsVersion = Just (StandardsVersion 3 9 3 (Just 1)), buildDepends = [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing], [Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing], [Rel (BinPkgName "cdbs") Nothing Nothing], [Rel (BinPkgName "ghc") Nothing Nothing], [Rel (BinPkgName "ghc-prof") Nothing Nothing]], buildDependsIndep = [[Rel (BinPkgName "ghc-doc") Nothing Nothing]] }) $ (newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))) log = ChangeLog [Entry {logPackage = "haskell-cabal-debian", logVersion = Debian.Version.parseDebianVersion ("2.6.2" :: String), logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = unlines [" * Fix a bug constructing the destination pathnames that was dropping", " files that were supposed to be installed into packages."], logWho = "David Fox ", logDate = "Thu, 20 Dec 2012 06:49:25 -0800"}] test3 :: Test test3 = TestLabel "test3" $ TestCase (do deb <- inputDebianization (Top "test-data/haskell-devscripts") assertEqual "test3" [] (diffDebianizations testDeb2 deb)) where testDeb2 :: Atoms testDeb2 = setL sourceFormat (Just Native3) $ setL rulesHead (Just "#!/usr/bin/make -f\n# -*- makefile -*-\n\n# Uncomment this to turn on verbose mode.\n#export DH_VERBOSE=1\n\nDEB_VERSION := $(shell dpkg-parsechangelog | egrep '^Version:' | cut -f 2 -d ' ')\n\nmanpages = $(shell cat debian/manpages)\n\n%.1: %.pod\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n%.1: %\n\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@\n\n.PHONY: build\nbuild: $(manpages)\n\ninstall-stamp:\n\tdh install\n\n.PHONY: install\ninstall: install-stamp\n\nbinary-indep-stamp: install-stamp\n\tdh binary-indep\n\ttouch $@\n\n.PHONY: binary-indep\nbinary-indep: binary-indep-stamp\n\n.PHONY: binary-arch\nbinary-arch: install-stamp\n\n.PHONY: binary\nbinary: binary-indep-stamp\n\n.PHONY: clean\nclean:\n\tdh clean\n\trm -f $(manpages)\n\n\n") $ setL compat (Just 7) $ setL copyright (Just (Right "This package was debianized by John Goerzen on\nWed, 6 Oct 2004 09:46:14 -0500.\n\nCopyright information removed from this test data.\n\n")) $ modL control (\ y -> y { source = Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"}) , maintainer = Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}) , uploaders = [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}] , priority = Just Extra , section = Just (MainSection "haskell") , buildDepends = (buildDepends y) ++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion ("7" :: String)))) Nothing]] , buildDependsIndep = (buildDependsIndep y) ++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]] , standardsVersion = Just (StandardsVersion 3 9 4 Nothing) , vcsFields = Set.union (vcsFields y) (Set.fromList [ VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts" , VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"]) , binaryPackages = [BinaryDebDescription { package = BinPkgName {unBinPkgName = "haskell-devscripts"} , architecture = All , binarySection = Nothing , binaryPriority = Nothing , essential = False , Deb.description = (T.intercalate "\n" ["Tools to help Debian developers build Haskell packages", " This package provides a collection of scripts to help build Haskell", " packages for Debian. Unlike haskell-utils, this package is not", " expected to be installed on the machines of end users.", " .", " This package is designed to support Cabalized Haskell libraries. It", " is designed to build a library for each supported Debian compiler or", " interpreter, generate appropriate postinst/prerm files for each one,", " generate appropriate substvars entries for each one, and install the", " package in the Debian temporary area as part of the build process."]) , relations = PackageRelations { Deb.depends = [ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "ghc"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.6" :: String)))) Nothing] , [Rel (BinPkgName {unBinPkgName = "cdbs"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "${misc:Depends}"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "html-xml-utils"}) Nothing Nothing] , [Rel (BinPkgName {unBinPkgName = "hscolour"}) (Just (GRE (Debian.Version.parseDebianVersion ("1.8" :: String)))) Nothing] , [Rel (BinPkgName {unBinPkgName = "ghc-haddock"}) (Just (GRE (Debian.Version.parseDebianVersion ("7.4" :: String)))) Nothing] ] , recommends = [] , suggests = [] , preDepends = [] , breaks = [] , Deb.conflicts = [] , provides_ = [] , replaces_ = [] , builtUsing = [] }}]}) $ (newDebianization log (Just 7) (Just (StandardsVersion 3 9 4 Nothing))) log = ChangeLog [Entry { logPackage = "haskell-devscripts" , logVersion = Debian.Version.parseDebianVersion ("0.8.13" :: String) , logDists = [ReleaseName {relName = "experimental"}] , logUrgency = "low" , logComments = " [ Joachim Breitner ]\n * Improve parsing of \"Setup register\" output, patch by David Fox\n * Enable creation of hoogle files, thanks to Kiwamu Okabe for the\n suggestion. \n\n [ Kiwamu Okabe ]\n * Need --html option to fix bug that --hoogle option don't output html file.\n * Support to create /usr/lib/ghc-doc/hoogle/*.txt for hoogle package.\n\n [ Joachim Breitner ]\n * Symlink hoogle\8217s txt files to /usr/lib/ghc-doc/hoogle/\n * Bump ghc dependency to 7.6 \n * Bump standards version\n" , logWho = "Joachim Breitner " , logDate = "Mon, 08 Oct 2012 21:14:50 +0200" }, Entry { logPackage = "haskell-devscripts" , logVersion = Debian.Version.parseDebianVersion ("0.8.12" :: String) , logDists = [ReleaseName {relName = "unstable"}] , logUrgency = "low" , logComments = " * Depend on ghc >= 7.4, adjusting to its haddock --interface-version\n behaviour.\n" , logWho = "Joachim Breitner " , logDate = "Sat, 04 Feb 2012 10:50:33 +0100"}] test4 :: Test test4 = TestLabel "test4" $ TestCase (do old <- inputDebianization (Top "test-data/clckwrks-dot-com/output") new <- debianization (Top "test-data/clckwrks-dot-com/input") (customize old) defaultAtoms assertEqual "test4" [] (diffDebianizations old (copyFirstLogEntry old new))) where customize :: Atoms -> Atoms -> IO Atoms customize old atoms = inputCabalization (Top "test-data/clckwrks-dot-com/input") atoms >>= return . newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing)) . modL control (\ y -> y {homepage = Just "http://www.clckwrks.com/"}) . setL sourceFormat (Just Native3) . modL missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) . setL revision Nothing . doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production")) . doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups" . fixRules . tight . setL changelog (getL changelog old) -- A log entry gets added when the Debianization is generated, -- it won't match so drop it for the comparison. serverNames = map BinPkgName ["clckwrks-dot-com-production"] -- , "clckwrks-dot-com-staging", "clckwrks-dot-com-development"] -- Insert a line just above the debhelper.mk include fixRules deb = modL rulesHead (\ mt -> (Just . f) (fromMaybe (getRulesHead deb) mt)) deb where f t = T.unlines $ concat $ map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text] else [line] :: [T.Text]) (T.lines t) {- mapAtoms f deb where f :: DebAtomKey -> DebAtom -> Set (DebAtomKey, DebAtom) f Source (DebRulesHead t) = singleton (Source, DebRulesHead (T.unlines $ concat $ map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk" then ["DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text] else [line] :: [T.Text]) (T.lines t))) f k a = singleton (k, a) -} tight deb = foldr (tightDependencyFixup -- For each pair (A, B) make sure that this package requires the -- same exact version of package B as the version of A currently -- installed during the build. [(BinPkgName "libghc-clckwrks-theme-clckwrks-dev", BinPkgName "haskell-clckwrks-theme-clckwrks-utils"), (BinPkgName "libghc-clckwrks-plugin-media-dev", BinPkgName "haskell-clckwrks-plugin-media-utils"), (BinPkgName "libghc-clckwrks-plugin-bugs-dev", BinPkgName "haskell-clckwrks-plugin-bugs-utils"), (BinPkgName "libghc-clckwrks-dev", BinPkgName "haskell-clckwrks-utils")]) deb serverNames theSite :: BinPkgName -> Site theSite deb = Site { domain = hostname' , serverAdmin = "logic@seereason.com" , server = theServer deb } theServer :: BinPkgName -> Server theServer deb = Server { hostname = case deb of BinPkgName "clckwrks-dot-com-production" -> hostname' _ -> hostname' , port = portNum deb , headerMessage = "Generated by clckwrks-dot-com/Setup.hs" , retry = "60" , serverFlags = [ "--http-port", show (portNum deb) , "--hide-port" , "--hostname", hostname' , "--top", databaseDirectory deb , "--enable-analytics" , "--jquery-path", "/usr/share/javascript/jquery/" , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" , "--jstree-path", jstreePath , "--json2-path",json2Path ] , installFile = InstallFile { execName = "clckwrks-dot-com-server" , destName = show (pretty deb) , sourceDir = Nothing , destDir = Nothing } } hostname' = "clckwrks.com" portNum :: BinPkgName -> Int portNum (BinPkgName deb) = case deb of "clckwrks-dot-com-production" -> 9029 "clckwrks-dot-com-staging" -> 9038 "clckwrks-dot-com-development" -> 9039 _ -> error $ "Unexpected package name: " ++ deb jstreePath = "/usr/share/clckwrks-0.13.2/jstree" json2Path = "/usr/share/clckwrks-0.13.2/json2" anyrel :: BinPkgName -> Relation anyrel b = Rel b Nothing Nothing test5 :: Test test5 = TestLabel "test5" $ TestCase (do old <- inputDebianization (Top "test-data/creativeprompts/output") let standards = standardsVersion (getL control old) level = getL compat old new <- debianization (Top "test-data/creativeprompts/input") (return . setL sourceFormat (Just Native3) . modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-data") All) . modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-development") All) . modL binaryArchitectures (Map.insert (BinPkgName "creativeprompts-production") All) . setL utilsPackageNames (Just (singleton (BinPkgName "creativeprompts-data"))) . modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-data") (T.intercalate "\n" [ "creativeprompts.com data files" , " Static data files for creativeprompts.com"])) . modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-production") (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server" , " Production version of the blog server, runs on port" , " 9021 with HTML validation turned off." ])) . modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-development") (T.intercalate "\n" [ "Configuration for running the creativeprompts.com server" , " Testing version of the blog server, runs on port" , " 8000 with HTML validation turned on." ])) . modL Atoms.description (Map.insertWith (error "test5") (BinPkgName "creativeprompts-backups") (T.intercalate "\n" [ "backup program for creativeprompts.com" , " Install this somewhere other than creativeprompts.com to run automated" , " backups of the database."])) . modL Atoms.depends (Map.insertWith union (BinPkgName "creativeprompts-server") (singleton (anyrel (BinPkgName "markdown")))) . modL execMap (Map.insertWith (error "Conflict in execMap") "trhsx" [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) . doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups" . doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development")) . doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production")) . setL changelog (getL changelog old) . (newDebianization' level standards)) defaultAtoms assertEqual "test5" [] (diffDebianizations old (copyFirstLogEntry old new))) where theSite :: BinPkgName -> Site theSite deb = Site { domain = hostname' , serverAdmin = "logic@seereason.com" , server = theServer deb } theServer :: BinPkgName -> Server theServer deb = Server { hostname = case deb of BinPkgName "clckwrks-dot-com-production" -> hostname' _ -> hostname' , port = portNum deb , headerMessage = "Generated by creativeprompts-dot-com/debian/Debianize.hs" , retry = "60" , serverFlags = [ "--http-port", show (portNum deb) , "--hide-port" , "--hostname", hostname' , "--top", databaseDirectory deb , "--enable-analytics" , "--jquery-path", "/usr/share/javascript/jquery/" , "--jqueryui-path", "/usr/share/javascript/jquery-ui/" , "--jstree-path", jstreePath , "--json2-path",json2Path ] , installFile = InstallFile { execName = "creativeprompts-server" , destName = show (pretty deb) , sourceDir = Nothing , destDir = Nothing } } hostname' = "creativeprompts.com" portNum :: BinPkgName -> Int portNum (BinPkgName deb) = case deb of "creativeprompts-production" -> 9022 "creativeprompts-staging" -> 9033 "creativeprompts-development" -> 9034 _ -> error $ "Unexpected package name: " ++ deb jstreePath = "/usr/share/clckwrks-0.13.2/jstree" json2Path = "/usr/share/clckwrks-0.13.2/json2" copyFirstLogEntry :: Atoms -> Atoms -> Atoms copyFirstLogEntry deb1 deb2 = modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2 where ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1) ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2) copyChangelog :: Atoms -> Atoms -> Atoms copyChangelog deb1 deb2 = modL changelog (const (getL changelog deb1)) deb2 test6 :: Test test6 = TestLabel "test6" $ TestCase (do result <- readProcessWithExitCode "runhaskell" ["-isrc", "test-data/artvaluereport2/input/debian/Debianize.hs"] "" assertEqual "test6" (ExitSuccess, "", "") result) test7 :: Test test7 = TestLabel "test7" $ TestCase (do new <- readProcessWithExitCode "runhaskell" ["-isrc", "debian/Debianize.hs"] "" assertEqual "test7" (ExitSuccess, "", "Ignored: ./debian/cabal-debian.1\nIgnored: ./debian/cabal-debian.manpages\n") new) test8 :: Test test8 = TestLabel "test8" $ TestCase ( do old <- inputDebianization (Top "test-data/artvaluereport-data/output") log <- inputChangeLog (Top "test-data/artvaluereport-data/input") new <- debianization (Top "test-data/artvaluereport-data/input") (return . modL buildDeps (Set.insert [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]) . modL control (\ y -> y {homepage = Just "http://artvaluereportonline.com"}) . setL sourceFormat (Just Native3) . setL changelog (Just log) . (newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing)))) defaultAtoms assertEqual "test8" [] (diffDebianizations old (copyChangelog old new)) ) test9 :: Test test9 = TestLabel "test9" $ TestCase ( do old <- inputDebianization (Top "test-data/alex/output") new <- debianization (Top "test-data/alex/input") (return . modL buildDeps (Set.insert [[Rel (BinPkgName "alex") Nothing Nothing]]) . doExecutable (BinPkgName "alex") (InstallFile {execName = "alex", destName = "alex", sourceDir = Nothing, destDir = Nothing}) . setL debVersion (Just (parseDebianVersion ("3.0.2-1~hackage1" :: String))) . setL sourceFormat (Just Native3) . modL control (\ y -> y {homepage = Just "http://www.haskell.org/alex/"}) . (\ atoms -> foldr (\ name atoms' -> modL installData (Map.insertWith union (BinPkgName "alex") (singleton (name, name))) atoms') atoms [ "AlexTemplate" , "AlexTemplate-debug" , "AlexTemplate-ghc" , "AlexTemplate-ghc-debug" , "AlexWrapper-basic" , "AlexWrapper-basic-bytestring" , "AlexWrapper-gscan" , "AlexWrapper-monad" , "AlexWrapper-monad-bytestring" , "AlexWrapper-monadUserState" , "AlexWrapper-monadUserState-bytestring" , "AlexWrapper-posn" , "AlexWrapper-posn-bytestring" , "AlexWrapper-strict-bytestring"]) . newDebianization' (Just 7) (Just (StandardsVersion 3 9 3 Nothing))) defaultAtoms assertEqual "test9" [] (diffDebianizations old (copyFirstLogEntry old new))) data Change k a = Created k a | Deleted k a | Modified k a a | Unchanged k a deriving (Eq, Show) diffMaps :: (Ord k, Eq a, Show k, Show a) => Map.Map k a -> Map.Map k a -> [Change k a] diffMaps old new = Map.elems (intersectionWithKey combine1 old new) ++ map (uncurry Deleted) (Map.toList (differenceWithKey combine2 old new)) ++ map (uncurry Created) (Map.toList (differenceWithKey combine2 new old)) where combine1 k a b = if a == b then Unchanged k a else Modified k a b combine2 _ _ _ = Nothing diffDebianizations :: Atoms -> Atoms -> String -- [Change FilePath T.Text] diffDebianizations old new = show (mconcat (map prettyChange (filter (not . isUnchanged) (diffMaps old' new')))) where old' = toFileMap (sortBinaryDebs old) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ old)) new' = toFileMap (sortBinaryDebs new) -- (sortBinaryDebs (fromMaybe newSourceDebDescription . getL control $ new)) isUnchanged (Unchanged _ _) = True isUnchanged _ = False prettyChange (Unchanged p _) = text ("Unchanged: " <> p <> "\n") prettyChange (Deleted p _) = text ("Deleted: " <> p <> "\n") prettyChange (Created p b) = text ("Created: " <> p <> "\n") <> prettyDiff ("old" p) ("new" p) -- We use split here instead of lines so we can -- detect whether the file has a final newline -- character. (contextDiff 2 mempty (T.split (== '\n') b)) prettyChange (Modified p a b) = text ("Modified: " <> p<> "\n") <> prettyDiff ("old" p) ("new" p) -- We use split here instead of lines so we can -- detect whether the file has a final newline -- character. (contextDiff 2 (T.split (== '\n') a) (T.split (== '\n') b)) sortBinaryDebs atoms = modL control (\ deb -> deb {binaryPackages = sortBy (compare `on` package) (binaryPackages deb)}) atoms testEntry :: ChangeLogEntry testEntry = either (error "Error in test changelog entry") fst (parseEntry (unlines [ "haskell-cabal-debian (2.6.2) unstable; urgency=low" , "" , " * Fix a bug constructing the destination pathnames that was dropping" , " files that were supposed to be installed into packages." , "" , " -- David Fox Thu, 20 Dec 2012 06:49:25 -0800" ])) main :: IO () main = runTestTT tests >>= putStrLn . show cabal-debian-3.9/src/Debian/Debianize/Options.hs0000644000175000017500000003330112236246354017622 0ustar dsfdsfmodule Debian.Debianize.Options ( compileArgs , options ) where import Data.Char (toLower, isDigit, ord) import Data.Lens.Lazy (setL, modL) import Data.Map as Map (insertWith) import Data.Set as Set (fromList, insert, union, singleton) import Data.Version (parseVersion) import Debian.Debianize.Atoms -- (Atoms, depends, conflicts) import Debian.Debianize.Goodies (doExecutable) import Debian.Debianize.Types (InstallFile(..), DebAction(..)) import Debian.Debianize.Utility (read') import Debian.Orphans () import Debian.Policy (SourceFormat(Quilt3), parseMaintainer) import Debian.Relation (BinPkgName(..), SrcPkgName(..), Relations, Relation(..)) import Debian.Relation.String (parseRelations) import Debian.Version (parseDebianVersion) import Distribution.PackageDescription (FlagName(..)) import Distribution.Package (PackageName(..)) import Prelude hiding (readFile, lines, null, log, sum) import System.Console.GetOpt (ArgDescr(..), OptDescr(..), ArgOrder(RequireOrder), getOpt') import System.FilePath ((), splitFileName) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Regex.TDFA ((=~)) compileArgs :: [String] -> Atoms -> Atoms compileArgs args atoms = case getOpt' RequireOrder options args of (os, [], [], []) -> foldl (flip ($)) atoms os (_, non, unk, errs) -> error ("Errors: " ++ show errs ++ ", Unrecognized: " ++ show unk ++ ", Non-Options: " ++ show non) -- | Options that modify other atoms. options :: [OptDescr (Atoms -> Atoms)] options = [ Option "v" ["verbose"] (ReqArg (\ s atoms -> setL verbosity (read' (\ s' -> error $ "verbose: " ++ show s') s) atoms) "n") "Change the amount of progress messages generated", Option "n" ["dry-run", "compare"] (NoArg (\ atoms -> setL dryRun True atoms)) "Just compare the existing debianization to the one we would generate.", Option "h?" ["help"] (NoArg (\ atoms -> setL debAction Usage atoms)) "Show this help text", Option "" ["executable"] (ReqArg (\ path x -> executableOption path (\ bin e -> doExecutable bin e x)) "SOURCEPATH or SOURCEPATH:DESTDIR") (unlines [ "Create an individual binary package to hold this executable. Other executables " , " and data files are gathered into a single utils package named 'haskell-packagename-utils'."]), Option "" ["ghc-version"] (ReqArg (\ ver x -> setL compilerVersion (Just (last (map fst (readP_to_S parseVersion ver)))) x) "VERSION") (unlines [ "Version of GHC in build environment. Without this option it is assumed that" , "the version of GHC in the build environment is the same as the one in the" , "environment in which cabal-debian is running. (the usual case.) The GHC" , "version is used to determine which packages are bundled with GHC - if a" , "package is bundled with GHC it is not necessary to add a build dependency for" , "that package to the debian/control file."]), Option "" ["disable-haddock"] (NoArg (setL noDocumentationLibrary True)) (unlines [ "Don't generate API documentation packages, usually named" , "libghc-packagename-doc. Use this if your build is crashing due to a" , "haddock bug."]), Option "" ["missing-dependency"] (ReqArg (\ name atoms -> modL missingDependencies (insert (BinPkgName name)) atoms) "DEB") (unlines [ "This is the counterpart to --disable-haddock. It prevents a package" , "from being added to the build dependencies. This is necessary, for example," , "when a dependency package was built with the --disable-haddock option, because" , "normally cabal-debian assumes that the -doc package exists and adds it as a" , "build dependency."]), Option "" ["source-package-name"] (ReqArg (\ name x -> setL sourcePackageName (Just (SrcPkgName name)) x) "NAME") (unlines [ "Use this name for the debian source package, the name in the Source field at the top of the" , "debian control file, and also at the very beginning of the debian/changelog file. By default" , "this is haskell-, where the cabal package name is downcased."]), Option "" ["disable-library-profiling"] (NoArg (setL noProfilingLibrary True)) (unlines [ "Don't generate profiling (-prof) library packages. This has been used in one case" , "where the package code triggered a compiler bug."]), Option "" ["maintainer"] (ReqArg (\ maint x -> setL maintainer (either (error ("Invalid maintainer string: " ++ show maint)) Just (parseMaintainer maint)) x) "Maintainer Name ") (unlines [ "Override the Maintainer name and email given in $DEBEMAIL or $EMAIL or $DEBFULLNAME or $FULLNAME"]), Option "" ["build-dep"] (ReqArg (\ name atoms -> modL buildDeps (case parseRelations name of Right rss -> Set.insert rss Left err -> error ("cabal-debian option --build-dep " ++ show name ++ ": " ++ show err)) atoms) "Debian package relations") (unlines [ "Add a dependency relation to the Build-Depends: field for this source package, e.g." , "" , " --build-dep libglib2.0-dev" , " --build-dep 'libglib2.0-dev >= 2.2'" ]), Option "" ["build-dep-indep"] (ReqArg (\ name atoms -> modL buildDepsIndep (case parseRelations name of Right rss -> Set.insert rss Left err -> error ("cabal-debian option --build-dep-indep " ++ show name ++ ": " ++ show err)) atoms) "Debian binary package name") (unlines [ "Similar to --build-dep, but the dependencies are added to Build-Depends-Indep, e.g.:" , "" , " --build-dep-indep perl" ]), Option "" ["dev-dep"] (ReqArg (\ name atoms -> modL extraDevDeps (Set.insert (Rel (BinPkgName name) Nothing Nothing)) atoms) "Debian binary package name") (unlines [ "Add an entry to the Depends: field of the -dev package, e.g." , "'--dev-dep libncurses5-dev'. It might be good if this implied --build-dep."]), Option "" ["depends"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL depends (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") (unlines [ "Generalized --dev-dep - specify pairs A:B of debian binary package names, each" , "A gets a Depends: B. Note that B can have debian style version relations"]), Option "" ["conflicts"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL conflicts (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") "Like --depends, modifies the Conflicts field.", Option "" ["replaces"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL replaces (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") "Like --depends, modifies the Replaces field.", Option "" ["provides"] (ReqArg (\ arg atoms -> foldr (\ (p, r) atoms' -> modL provides (Map.insertWith union p (singleton r)) atoms') atoms (parseDeps arg)) "deb:deb,deb:deb,...") "Like --depends, modifies the Provides field.", Option "" ["map-dep"] (ReqArg (\ pair atoms -> case break (== '=') pair of (cab, (_ : deb)) -> modL extraLibMap (Map.insertWith Set.union cab (singleton (rels deb))) atoms (_, "") -> error "usage: --map-dep CABALNAME=RELATIONS") "CABALNAME=RELATIONS") (unlines [ "Specify what debian package name corresponds with a name that appears in" , "the Extra-Library field of a cabal file, e.g. --map-dep cryptopp=libcrypto-dev." , "I think this information is present somewhere in the packaging system, but" , "I'm not sure of the details."]), Option "" ["deb-version"] (ReqArg (\ version atoms -> setL debVersion (Just (parseDebianVersion version)) atoms) "VERSION") "Specify the version number for the debian package. This will pin the version and should be considered dangerous.", Option "" ["revision"] (ReqArg (setL revision . Just) "REVISION") "Add this string to the cabal version to get the debian version number. By default this is '-1~hackage1'. Debian policy says this must either be empty (--revision '') or begin with a dash.", Option "" ["epoch-map"] (ReqArg (\ pair atoms -> case break (== '=') pair of (_, (_ : ['0'])) -> atoms (cab, (_ : [d])) | isDigit d -> modL epochMap (Map.insertWith (flip const) (PackageName cab) (ord d - ord '0')) atoms _ -> error "usage: --epoch-map CABALNAME=DIGIT") "CABALNAME=DIGIT") "Specify a mapping from the cabal package name to a digit to use as the debian package epoch number, e.g. --epoch-map HTTP=1", Option "" ["exec-map"] (ReqArg (\ s atoms -> case break (== '=') s of (cab, (_ : deb)) -> modL execMap (Map.insertWith (flip const) cab (rels deb)) atoms _ -> error "usage: --exec-map EXECNAME=RELATIONS") "EXECNAME=RELATIONS") "Specify a mapping from the name appearing in the Build-Tool field of the cabal file to a debian binary package name, e.g. --exec-map trhsx=haskell-hsx-utils", Option "" ["omit-lt-deps"] (NoArg (setL omitLTDeps True)) (unlines [ "Remove all less-than dependencies from the generated control file. Less-than" , "dependencies are less useful and more troublesome for debian packages than cabal," , "because you can't install multiple versions of a given debian package. For more" , "google 'cabal hell'."]), Option "" ["quilt"] (NoArg (setL sourceFormat (Just Quilt3))) "The package has an upstream tarball, write '3.0 (quilt)' into source/format.", Option "" ["builddir"] (ReqArg (\ s atoms -> setL buildDir (Just (s "build")) atoms) "PATH") (unlines [ "Subdirectory where cabal does its build, dist/build by default, dist-ghc when" , "run by haskell-devscripts. The build subdirectory is added to match the" , "behavior of the --builddir option in the Setup script."]), Option "f" ["flags"] (ReqArg (\ fs atoms -> modL cabalFlagAssignments (union (fromList (flagList fs))) atoms) "FLAGS") (unlines [ "Flags to pass to the finalizePackageDescription function in" , "Distribution.PackageDescription.Configuration when loading the cabal file."]), Option "" ["debianize"] (NoArg (\ atoms -> setL debAction Debianize atoms)) "Deprecated - formerly used to get what is now the normal benavior.", Option "" ["substvar"] (ReqArg (\ name atoms -> setL debAction (SubstVar (read' (\ s -> error $ "substvar: " ++ show s) name)) atoms) "Doc, Prof, or Dev") (unlines [ "With this option no debianization is generated. Instead, the list" , "of dependencies required for the dev, prof or doc package (depending" , "on the argument) is printed to standard output. These can be added" , "to the appropriate substvars file. (This is an option whose use case" , "is lost in the mists of time.)"]) ] anyrel :: BinPkgName -> Relation anyrel x = Rel x Nothing Nothing -- | Process a --executable command line argument executableOption :: String -> (BinPkgName -> InstallFile -> a) -> a executableOption arg f = case span (/= ':') arg of (sp, md) -> let (sd, name) = splitFileName sp in f (BinPkgName name) (InstallFile { execName = name , destName = name , sourceDir = case sd of "./" -> Nothing; _ -> Just sd , destDir = case md of (':' : dd) -> Just dd; _ -> Nothing }) parseDeps :: String -> [(BinPkgName, Relation)] parseDeps arg = map pair (split arg) where split s = case s =~ "^[ \t,]*([^,]+)[ \t,]*" :: (String, String, String, [String]) of (_, _, tl, [hd]) -> hd : split tl (_, _, "", _) -> [] _ -> error $ "Invalid dependency: " ++ show s pair s = case s =~ "^[ \t:]*([^ \t:]+)[ \t]*:[ \t]*(.+)[ \t]*" :: (String, String, String, [String]) of (_, _, _, [x, y]) -> (b x, anyrel (b y)) _ -> error $ "Invalid dependency: " ++ show s -- Lifted from Distribution.Simple.Setup, since it's not exported. flagList :: String -> [(FlagName, Bool)] flagList = map tagWithValue . words where tagWithValue ('-':name) = (FlagName (map toLower name), False) tagWithValue name = (FlagName (map toLower name), True) b :: String -> BinPkgName b = BinPkgName rels :: String -> Relations rels s = case parseRelations s of Right relss -> relss _ -> error $ "Parse error in debian relations: " ++ show s cabal-debian-3.9/src/Debian/Debianize/SubstVars.hs0000644000175000017500000001754512236246354020137 0ustar dsfdsf{-# LANGUAGE ScopedTypeVariables, TupleSections, TypeSynonymInstances #-} {-# OPTIONS -Wall -fno-warn-name-shadowing #-} -- | Support for generating Debianization from Cabal data. module Debian.Debianize.SubstVars ( substvars ) where import Control.Exception (SomeException, try) import Control.Monad (foldM) import Control.Monad.Reader (ReaderT(runReaderT)) import Control.Monad.Trans (lift) import Data.Lens.Lazy (getL, modL) import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Data.Text (pack) import Debian.Control import Debian.Debianize.Atoms (Atoms, compiler, dryRun, packageInfo) import Debian.Debianize.Dependencies (cabalDependencies, debDeps, debNameFromType, filterMissing) import Debian.Debianize.Input (inputCabalization) import Debian.Debianize.Types (Top(Top), PackageInfo(PackageInfo, cabalName, devDeb, profDeb, docDeb), DebType) import Debian.Debianize.Utility (buildDebVersionMap, DebMap, showDeps, dpkgFileMap, cond, debOfFile, (!), diffFile, replaceFile) import qualified Debian.Relation as D import Distribution.Package (Dependency(..), PackageName(PackageName)) import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) import Distribution.Simple.Utils (die) import Distribution.Text (display) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (()) import Text.PrettyPrint.ANSI.Leijen (pretty) -- | Expand the contents of the .substvars file for a library package. -- Each cabal package corresponds to a directory -, -- either in /usr/lib or in /usr/lib/haskell-packages/ghc/lib. In -- that directory is a compiler subdirectory such as ghc-6.8.2. In -- the ghc subdirectory is one or two library files of the form -- libHS-.a and libHS-_p.a. We can -- determine the debian package names by running dpkg -S on these -- names, or examining the /var/lib/dpkg/info/\*.list files. From -- these we can determine the source package name, and from that the -- documentation package name. substvars :: Atoms -> DebType -- ^ The type of deb we want to write substvars for - Dev, Prof, or Doc -> IO () substvars atoms debType = do atoms' <- inputCabalization (Top ".") atoms debVersions <- buildDebVersionMap atoms'' <- libPaths (fromMaybe (error "substvars") $ getL compiler atoms') debVersions atoms' control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control" substvars' atoms'' debType control substvars' :: Atoms -> DebType -> Control' String -> IO () substvars' atoms debType control = case (missingBuildDeps, path) of -- There should already be a .substvars file produced by dh_haskell_prep, -- keep the relations listed there. They will contain something like this: -- libghc-cabal-debian-prof.substvars: -- haskell:Depends=ghc-prof (<< 6.8.2-999), ghc-prof (>= 6.8.2), libghc-cabal-debian-dev (= 0.4) -- libghc-cabal-debian-dev.substvars: -- haskell:Depends=ghc (<< 6.8.2-999), ghc (>= 6.8.2) -- haskell-cabal-debian-doc.substvars: -- haskell:Depends=ghc-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999) ([], Just path') -> readFile path' >>= \ old -> let new = addDeps old in diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path')) (\ diff -> if getL dryRun atoms then putStr diff else replaceFile path' new) ([], Nothing) -> return () (missing, _) -> die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map (show . pretty . fst) missing) ++ "\nIf this is an obsolete package you may need to withdraw the old versions from the\n" ++ "upstream repository, and uninstall and purge it from your local system.") where addDeps old = case partition (isPrefixOf "haskell:Depends=") (lines old) of ([], other) -> unlines (("haskell:Depends=" ++ showDeps (filterMissing atoms deps)) : other) (hdeps, more) -> case deps of [] -> unlines (hdeps ++ more) _ -> unlines (map (++ (", " ++ showDeps (filterMissing atoms deps))) hdeps ++ more) path = fmap (\ (D.BinPkgName x) -> "debian/" ++ x ++ ".substvars") name name = debNameFromType control debType deps = debDeps debType atoms control -- We must have build dependencies on the profiling and documentation packages -- of all the cabal packages. missingBuildDeps = let requiredDebs = concat (map (\ (Dependency name _) -> case Map.lookup name (getL packageInfo atoms) of Just info -> let prof = maybe (devDeb info) Just (profDeb info) in let doc = docDeb info in catMaybes [prof, doc] Nothing -> []) (cabalDependencies atoms)) in filter (not . (`elem` buildDepNames) . fst) requiredDebs buildDepNames :: [D.BinPkgName] buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps) buildDeps :: D.Relations buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi) --sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control))) bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control libPaths :: Compiler -> DebMap -> Atoms -> IO Atoms libPaths compiler debVersions atoms | compilerFlavor compiler == GHC = do a <- getDirPaths "/usr/lib" b <- getDirPaths "/usr/lib/haskell-packages/ghc/lib" -- Build a map from names of installed debs to version numbers dpkgFileMap >>= runReaderT (foldM (packageInfo' compiler debVersions) atoms (a ++ b)) | True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler) where getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id packageInfo' :: Compiler -> DebMap -> Atoms -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO Atoms packageInfo' compiler debVersions atoms (d, f) = case parseNameVersion f of Nothing -> return atoms Just (p, v) -> lift (doesDirectoryExist (d f cdir)) >>= cond (return atoms) (info (p, v)) where parseNameVersion s = case (break (== '-') (reverse s)) of (_a, "") -> Nothing (a, b) -> Just (reverse (tail b), reverse a) cdir = display (compilerId compiler) info (p, v) = do dev <- debOfFile ("^" ++ d p ++ "-" ++ v cdir "libHS" ++ p ++ "-" ++ v ++ ".a$") prof <- debOfFile ("^" ++ d p ++ "-" ++ v cdir "libHS" ++ p ++ "-" ++ v ++ "_p.a$") doc <- debOfFile ("/" ++ p ++ ".haddock$") return $ modL packageInfo (Map.insert (PackageName p) (PackageInfo { cabalName = PackageName p , devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev , profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof , docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) atoms cabal-debian-3.9/src/Debian/Debianize/Utility.hs0000644000175000017500000002241312236246354017634 0ustar dsfdsf-- | Functions used by but not related to cabal-debian, these could -- conceivably be moved into more general libraries. {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Debian.Debianize.Utility ( DebMap , buildDebVersionMap , (!) , trim , strictReadF , replaceFile , modifyFile , diffFile , removeIfExists , dpkgFileMap , cond , debOfFile , readFile' , readFileMaybe , showDeps , showDeps' , withCurrentDirectory , getDirectoryContents' , setMapMaybe , zipMaps , foldEmpty , maybeL , indent , maybeRead , read' ) where import Control.Applicative ((<$>)) import Control.Exception as E (catch, try, bracket, IOException) import Control.Monad (when) import Control.Monad.Reader (ReaderT, ask) import Data.Char (isSpace) import Data.List as List (isSuffixOf, intercalate, map, lines) import Data.Lens.Lazy (Lens, modL) import Data.Map as Map (Map, foldWithKey, empty, fromList, findWithDefault, insert, map, lookup) import Data.Maybe (catMaybes, mapMaybe, listToMaybe, fromMaybe) import Data.Set (Set, toList) import qualified Data.Set as Set import Data.Text as Text (Text, unpack, lines) import Data.Text.IO (hGetContents) import Debian.Control (parseControl, lookupP, Field'(Field), unControl, stripWS) import Debian.Version (DebianVersion, prettyDebianVersion) import Debian.Version.String (parseDebianVersion) import qualified Debian.Relation as D import Prelude hiding (map, lookup) import System.Directory (doesFileExist, doesDirectoryExist, removeFile, renameFile, removeDirectory, getDirectoryContents, getCurrentDirectory, setCurrentDirectory) import System.Exit(ExitCode(ExitSuccess, ExitFailure)) import System.FilePath ((), dropExtension) import System.IO (IOMode (ReadMode), withFile, openFile, hSetBinaryMode) import System.IO.Error (isDoesNotExistError, catchIOError) import System.Process (readProcessWithExitCode, showCommandForUser) import Text.PrettyPrint.ANSI.Leijen (pretty) type DebMap = Map.Map D.BinPkgName (Maybe DebianVersion) -- | Read and parse the status file for installed debian packages. buildDebVersionMap :: IO DebMap buildDebVersionMap = readFile "/var/lib/dpkg/status" >>= return . either (const []) unControl . parseControl "/var/lib/dpkg/status" >>= mapM (\ p -> case (lookupP "Package" p, lookupP "Version" p) of (Just (Field (_, name)), Just (Field (_, version))) -> return (Just (D.BinPkgName (stripWS name), Just (parseDebianVersion (stripWS version)))) _ -> return Nothing) >>= return . Map.fromList . catMaybes (!) :: DebMap -> D.BinPkgName -> DebianVersion m ! k = maybe (error ("No version number for " ++ (show . pretty $ k) ++ " in " ++ show (Map.map (maybe Nothing (Just . prettyDebianVersion)) m))) id (Map.findWithDefault Nothing k m) trim :: String -> String trim = dropWhile isSpace strictReadF :: (Text -> r) -> FilePath -> IO r strictReadF f path = withFile path ReadMode (\h -> hGetContents h >>= (\x -> return $! f x)) -- strictRead = strictReadF id -- | Write a file which we might still be reading from in -- order to compute the text argument. replaceFile :: FilePath -> String -> IO () replaceFile path text = do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) renameFile path back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) writeFile path text where back = path ++ "~" -- | Compute the new file contents from the old. If f returns Nothing -- do not write. modifyFile :: FilePath -> (String -> IO (Maybe String)) -> IO () modifyFile path f = do removeFile back `E.catch` (\ (e :: IOException) -> when (not (isDoesNotExistError e)) (ioError e)) try (renameFile path back) >>= either (\ (e :: IOException) -> if not (isDoesNotExistError e) then ioError e else f "" >>= maybe (return ()) (writeFile path)) (\ () -> readFile back >>= f >>= maybe (return ()) (writeFile path)) where back = path ++ "~" diffFile :: FilePath -> Text -> IO (Maybe String) diffFile path text = readProcessWithExitCode cmd args (unpack text) >>= \ (code, out, _err) -> case code of ExitSuccess -> return Nothing ExitFailure 1 -> return (Just out) _ -> error (showCommandForUser cmd args {- ++ " < " ++ show text -} ++ " -> " ++ show code) where cmd = "diff" args = ["-ruw", path, "-"] removeFileIfExists :: FilePath -> IO () removeFileIfExists x = doesFileExist x >>= (`when` (removeFile x)) removeDirectoryIfExists :: FilePath -> IO () removeDirectoryIfExists x = doesDirectoryExist x >>= (`when` (removeDirectory x)) removeIfExists :: FilePath -> IO () removeIfExists x = removeFileIfExists x >> removeDirectoryIfExists x -- |Create a map from pathname to the names of the packages that contains that pathname. -- We need to make sure we consume all the files, so dpkgFileMap :: IO (Map.Map FilePath (Set.Set D.BinPkgName)) dpkgFileMap = do let fp = "/var/lib/dpkg/info" names <- getDirectoryContents fp >>= return . filter (isSuffixOf ".list") let paths = List.map (fp ) names files <- mapM (strictReadF Text.lines) paths return $ Map.fromList $ zip (List.map dropExtension names) (List.map (Set.fromList . List.map (D.BinPkgName . unpack)) $ files) -- |Given a path, return the name of the package that owns it. debOfFile :: FilePath -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO (Maybe D.BinPkgName) debOfFile path = do mp <- ask return $ testPath (lookup path mp) where -- testPath :: Maybe (Set.Set FilePath) -> Maybe FilePath testPath Nothing = Nothing testPath (Just s) = case Set.size s of 1 -> Just (Set.findMin s) _ -> Nothing cond :: t -> t -> Bool -> t cond ifF _ifT False = ifF cond _ifF ifT True = ifT readFile' :: FilePath -> IO Text readFile' path = do file <- openFile path ReadMode hSetBinaryMode file True hGetContents file readFileMaybe :: FilePath -> IO (Maybe Text) readFileMaybe path = (Just <$> readFile' path) `catchIOError` (\ _ -> return Nothing) -- Would like to call pretty instead of D.prettyRelations, but the -- Pretty instance for [a] doesn't work for us. showDeps :: [[D.Relation]] -> String showDeps = show . D.prettyRelations -- The extra space after prefix' is here for historical reasons(?) showDeps' :: [a] -> [[D.Relation]] -> String showDeps' prefix xss = intercalate ("\n" ++ prefix' ++ " ") . Prelude.lines . show . D.prettyRelations $ xss where prefix' = List.map (\ _ -> ' ') prefix -- | From Darcs.Utils withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory name m = E.bracket (do cwd <- getCurrentDirectory setCurrentDirectory name return cwd) (\oldwd -> setCurrentDirectory oldwd {- `catchall` return () -}) (const m) {- catchall :: IO a -> IO a -> IO a a `catchall` b = a `catchNonSignal` (\_ -> b) -- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows -- us to catch anything but a signal. Useful for situations where we want -- don't want to inhibit ctrl-C. catchNonSignal :: IO a -> (E.SomeException -> IO a) -> IO a catchNonSignal comp handler = catch comp handler' where handler' se = case fromException se :: Maybe SignalException of Nothing -> handler se Just _ -> E.throw se newtype SignalException = SignalException Signal deriving (Show, Typeable) instance Exception SignalException where toException e = SomeException e fromException (SomeException e) = cast e -} getDirectoryContents' :: FilePath -> IO [FilePath] getDirectoryContents' dir = getDirectoryContents dir >>= return . filter (not . dotFile) where dotFile "." = True dotFile ".." = True dotFile _ = False setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b setMapMaybe p = Set.fromList . mapMaybe p . toList zipMaps :: Ord k => (k -> Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b -> Map k c zipMaps f m n = foldWithKey h (foldWithKey g empty m) n where g k a r = case f k (Just a) (lookup k n) of Just c -> Map.insert k c r -- Both m and n have entries for k Nothing -> r -- Only m has an entry for k h k b r = case lookup k m of Nothing -> case f k Nothing (Just b) of Just c -> Map.insert k c r -- Only n has an entry for k Nothing -> r Just _ -> r foldEmpty :: r -> ([a] -> r) -> [a] -> r foldEmpty r _ [] = r foldEmpty _ f l = f l -- | If the current value of getL x is Nothing, replace it with f. maybeL :: Lens a (Maybe b) -> Maybe b -> a -> a maybeL lens mb x = modL lens (maybe mb Just) x indent :: [Char] -> String -> String indent prefix text = unlines (List.map (prefix ++) (List.lines text)) maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads read' :: Read a => (String -> a) -> String -> a read' f s = fromMaybe (f s) (maybeRead s) -- read' :: Read a => String -> a -- read' s = trace ("read " ++ show s) (read s) cabal-debian-3.9/src/Debian/Debianize/Types/0000755000175000017500000000000012236246354016737 5ustar dsfdsfcabal-debian-3.9/src/Debian/Debianize/Types/VersionSplits.hs0000644000175000017500000001152212236246354022120 0ustar dsfdsf{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} module Debian.Debianize.Types.VersionSplits ( VersionSplits , packageRangesFromVersionSplits , makePackage , insertSplit , doSplits , knownVersionSplits ) where import Data.Version (Version(Version), showVersion) import Debian.Debianize.Interspersed (Interspersed(leftmost, pairs, foldInverted), foldTriples) import Data.Map as Map (Map, fromList) import Debian.Orphans () import qualified Debian.Relation as D import Debian.Version (parseDebianVersion) import Distribution.Package (PackageName(PackageName)) import Distribution.Version (VersionRange, anyVersion, intersectVersionRanges, earlierVersion, orLaterVersion) import Prelude hiding (init, unlines, log) -- | Describes a mapping from cabal package name and version to debian -- package names. For example, versions of the cabal QuickCheck -- package less than 2 are mapped to "quickcheck1", while version 2 or -- greater is mapped to "quickcheck2". data VersionSplits = VersionSplits { oldestPackage :: String -- ^ The name given to versions older than the oldest split. , splits :: [(Version, String)] -- ^ Each pair is The version where the split occurs, and the -- name to use for versions greater than or equal to that -- version. This list assumed to be in (must be kept in) -- ascending version number order. } deriving (Eq, Ord, Show) makePackage :: String -> VersionSplits makePackage name = VersionSplits {oldestPackage = name, splits = []} -- | Split the version range and give the older packages a new name. insertSplit :: Version -> String -> VersionSplits -> VersionSplits insertSplit ver@(Version _ _) ltname sp@(VersionSplits {}) = -- (\ x -> trace ("insertSplit " ++ show (ltname, ver, sp) ++ " -> " ++ show x) x) $ case splits sp of -- This is the oldest split, change oldestPackage and insert a new head pair (ver', _) : _ | ver' > ver -> sp {oldestPackage = ltname, splits = (ver, oldestPackage sp) : splits sp} [] -> sp {oldestPackage = ltname, splits = [(ver, oldestPackage sp)]} -- Not the oldest split, insert it in its proper place. _ -> sp {splits = reverse (insert (reverse (splits sp)))} where -- Insert our new split into the reversed list insert ((ver', name') : more) = if ver' < ver then (ver, name') : (ver', ltname) : more else (ver', name') : insert more -- ver' is older, change oldestPackage insert [] = [(ver, oldestPackage sp)] -- ltname = base ++ "-" ++ (show (last ns - 1)) instance Interspersed VersionSplits String Version where leftmost (VersionSplits {splits = []}) = error "Empty Interspersed instance" leftmost (VersionSplits {oldestPackage = p}) = p pairs (VersionSplits {splits = xs}) = xs packageRangesFromVersionSplits :: VersionSplits -> [(String, VersionRange)] packageRangesFromVersionSplits s = foldInverted (\ older dname newer more -> (dname, intersectVersionRanges (maybe anyVersion orLaterVersion older) (maybe anyVersion earlierVersion newer)) : more) [] s doSplits :: VersionSplits -> Maybe D.VersionReq -> String doSplits s version = foldTriples' (\ ltName v geName _ -> let split = parseDebianVersion (showVersion v) in case version of Nothing -> geName Just (D.SLT v') | v' <= split -> ltName -- Otherwise use ltName only when the split is below v' Just (D.EEQ v') | v' < split -> ltName Just (D.LTE v') | v' < split -> ltName Just (D.GRE v') | v' < split -> ltName Just (D.SGR v') | v' < split -> ltName _ -> geName) (oldestPackage s) s where foldTriples' :: (String -> Version -> String -> String -> String) -> String -> VersionSplits -> String foldTriples' = foldTriples -- | These are the instances of debian names changing that I know -- about. I know they really shouldn't be hard coded. Send a patch. -- Note that this inherits the lack of type safety of the mkPkgName -- function. knownVersionSplits :: Map PackageName VersionSplits knownVersionSplits = Map.fromList [ (PackageName "parsec", VersionSplits {oldestPackage = "parsec2", splits = [(Version [3] [], "parsec3")]}) , (PackageName "QuickCheck", VersionSplits {oldestPackage = "quickcheck1", splits = [(Version [2] [], "quickcheck2")]}) -- This just gives a special case cabal to debian name mapping. , (PackageName "gtk2hs-buildtools", VersionSplits {oldestPackage = "gtk2hs-buildtools", splits = []}) ] cabal-debian-3.9/src/Debian/Debianize/Debianize.hs0000644000175000017500000004247712236246354020077 0ustar dsfdsf{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-} {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} -- | Generate a package Debianization from Cabal data and command line -- options. module Debian.Debianize.Debianize ( cabalDebian , callDebianize , runDebianize , runDebianize' , debianize , debianization , writeDebianization , describeDebianization , compareDebianization , validateDebianization ) where import Control.Applicative ((<$>), (<*>), pure) import Control.Exception as E (catch, throw) import Data.Algorithm.Diff.Context (contextDiff) import Data.Algorithm.Diff.Pretty (prettyDiff) import Data.Lens.Lazy (getL, setL, modL) import Data.List as List (unlines, intercalate, nub) import Data.Map as Map (lookup, toList, elems) import Data.Maybe import Data.Monoid ((<>)) import Data.Set as Set (toList) import Data.Text as Text (Text, unpack, split) import Data.Version (Version) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) import Debian.Debianize.Atoms (Atoms, packageDescription, compat, watch, control, copyright, changelog, comments, sourcePriority, sourceSection, debAction, validate, dryRun, debVersion, revision, sourcePackageName, epochMap, extraLibMap) import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), PackageType(..)) import Debian.Debianize.Dependencies (debianName) import Debian.Debianize.Files (toFileMap) import Debian.Debianize.Finalize (finalizeDebianization) import Debian.Debianize.Goodies (watchAtom) import Debian.Debianize.Input (inputDebianization, inputCabalization, inputLicenseFile, inputMaintainer, inputChangeLog) import Debian.Debianize.Options (options, compileArgs) import Debian.Debianize.SubstVars (substvars) import Debian.Debianize.Types (DebAction(..), Top(Top, unTop)) import Debian.Debianize.Utility (withCurrentDirectory, foldEmpty, replaceFile, zipMaps, indent, read') import Debian.Policy (PackagePriority(Optional), Section(MainSection), getDebhelperCompatLevel) import Debian.Relation (SrcPkgName(..), BinPkgName(BinPkgName), Relation(Rel)) import Debian.Release (parseReleaseName) import Debian.Version (DebianVersion, parseDebianVersion, buildDebianVersion) import Debian.Time (getCurrentLocalRFC822Time) import Distribution.License (License(AllRightsReserved)) import Distribution.Package (PackageIdentifier(..)) import qualified Distribution.PackageDescription as Cabal import Prelude hiding (writeFile, unlines) import System.Console.GetOpt (usageInfo) import System.Directory (doesFileExist, Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing) import System.Environment (getArgs, getEnv, getProgName, withArgs) import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((), takeDirectory) import System.IO.Error (catchIOError) import System.Posix.Env (setEnv) import System.Process (readProcessWithExitCode) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) -- | The main function for the cabal-debian executable. cabalDebian :: Atoms -> IO () cabalDebian defaultAtoms = compileEnvironmentArgs defaultAtoms >>= compileCommandlineArgs >>= \ atoms -> case getL debAction atoms of SubstVar debType -> substvars atoms debType Debianize -> debianize (Top ".") return defaultAtoms Usage -> do progName <- getProgName let info = unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: " , "" , " " ++ progName ++ " --maintainer 'Maintainer Name '." , "" , "This will read the package's cabal file and any existing debian/changelog file and" , "deduce what it can about the debianization, then it will create or modify files in" , "the debian subdirectory. Note that it will not remove any files in debian, and" , "these could affect the operation of the debianization in unknown ways. For this" , "reason I recommend either using a pristine unpacked directory each time, or else" , "using a revision control system to revert the package to a known state before running." , "The following additional options are available:" ] putStrLn (usageInfo info options) compileEnvironmentArgs :: Atoms -> IO Atoms compileEnvironmentArgs atoms0 = (compileArgs <$> (read' (\ s -> error $ "compileEnvrionmentArgs: " ++ show s) <$> getEnv "CABALDEBIAN") <*> pure atoms0) `catchIOError` const (return atoms0) compileCommandlineArgs :: Atoms -> IO Atoms compileCommandlineArgs atoms0 = compileArgs <$> getArgs <*> pure atoms0 -- | Compile the given arguments into an Atoms value and run the -- debianize function. This is basically equivalent to @cabal-debian -- --debianize@, except that the command line arguments come from the -- function parameter. callDebianize :: [String] -> Atoms -> IO () callDebianize args defaultAtoms = withArgs args (debianize (Top ".") return defaultAtoms) -- | Put an argument list into the @CABALDEBIAN@ environment variable -- and then run the script in debian/Debianize.hs. If this exists and -- succeeds the return value is True, it may be assumed that a -- debianization was created in the debian subdirectory of the current -- directory. This is used to create customized debianizations that -- are to sophisticated for the command line argument interface -- available to the cabal-debian executable. runDebianize :: [String] -> IO Bool runDebianize args = getEnv "HOME" >>= \ home -> doesFileExist "debian/Debianize.hs" >>= \ exists -> case exists of False -> return False True -> let autobuilderd = "-i.:" ++ home ".autobuilder.d" in putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ([autobuilderd, "debian/Debianize.hs"] ++ args) "" >>= \ result -> case result of (ExitSuccess, _, _) -> return True (code, out, err) -> error ("runDebianize failed with " ++ show code ++ ":\n stdout: " ++ show out ++"\n stderr: " ++ show err) -- | Insert a value for CABALDEBIAN into the environment that the -- withEnvironment* functions above will find and use. E.g. -- putEnvironmentFlags ["--dry-run", "--validate"] (debianize defaultFlags) putEnvironmentArgs :: [String] -> IO () putEnvironmentArgs fs = setEnv "CABALDEBIAN" (show fs) True -- | Call runDebianize with the given working directory. runDebianize' :: Top -> [String] -> IO Bool runDebianize' top args = withCurrentDirectory (unTop top) $ runDebianize args -- | Depending on the options in @atoms@, either validate, describe, -- or write the generated debianization. debianize :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO () debianize top customize defaultAtoms = debianization top customize defaultAtoms >>= \ atoms -> if getL validate atoms then inputDebianization top >>= \ old -> return (validateDebianization old atoms) else if getL dryRun atoms then inputDebianization top >>= \ old -> putStr ("Debianization (dry run):\n" ++ compareDebianization (ensureCopyright old) atoms) else writeDebianization top atoms where ensureCopyright = modL copyright (maybe (Just (Left AllRightsReserved)) Just) -- | Given an Atoms value, get any additional configuration -- information from the environment, read the cabal package -- description and possibly the debian/changelog file, then generate -- and return the new debianization (along with the data directory -- computed from the cabal package description.) debianization :: Top -> (Atoms -> IO Atoms) -> Atoms -> IO Atoms debianization top customize defaultAtoms = do atoms <- compileEnvironmentArgs defaultAtoms >>= compileCommandlineArgs >>= customize >>= inputCabalization top log <- (Just <$> inputChangeLog top) `E.catch` (\ (_ :: IOError) -> return Nothing) date <- getCurrentLocalRFC822Time maint <- inputMaintainer atoms >>= maybe (error "Missing value for --maintainer") return level <- getDebhelperCompatLevel copyright <- withCurrentDirectory (unTop top) $ inputLicenseFile (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ unTop top) (getL packageDescription atoms)) return $ debianization' date copyright maint level log atoms debianization' :: String -- ^ current date -> Maybe Text -- ^ copyright -> NameAddr -- ^ maintainer -> Maybe Int -- ^ Default standards version -> Maybe ChangeLog -> Atoms -- ^ Debianization specification -> Atoms -- ^ New debianization debianization' date copy maint level log deb = finalizeDebianization $ modL compat (maybe level Just) $ modL changelog (maybe log Just) $ setL sourcePriority (Just Optional) $ setL sourceSection (Just (MainSection "haskell")) $ setL watch (Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))) $ modL copyright (maybe (finalizeCopyright copy) Just) $ versionInfo maint date $ addExtraLibDependencies $ -- Do we want to replace the atoms in the old deb, or add these? -- Or should we delete even more information from the original, -- keeping only the changelog? Probably the latter. So this is -- somewhat wrong. deb where pkgDesc = fromMaybe (error "debianization") $ getL packageDescription deb finalizeCopyright (Just x) = Just (Right x) finalizeCopyright Nothing = Just (Left (Cabal.license pkgDesc)) -- | Set the debianization's version info - everything that goes into -- the new changelog entry, source package name, exact debian version, -- log comments, maintainer name, revision date. versionInfo :: NameAddr -> String -> Atoms -> Atoms versionInfo debianMaintainer date deb = modL changelog (const (Just newLog)) $ modL control (\ y -> y { source = Just sourceName, Debian.maintainer = Just debianMaintainer }) deb where newLog = case getL changelog deb of Nothing -> ChangeLog [newEntry] Just (ChangeLog oldEntries) -> case dropWhile (\ entry -> logVersion entry > logVersion newEntry) oldEntries of -- If the new package version number matches the old, merge the new and existing log entries entry@(Entry {logVersion = d}) : older | d == logVersion newEntry -> ChangeLog (merge entry newEntry : older) -- Otherwise prepend the new entry entries -> ChangeLog (newEntry : entries) newEntry = Entry { logPackage = show (pretty sourceName) , logVersion = convertVersion debinfo (pkgVersion pkgId) , logDists = [parseReleaseName "unstable"] , logUrgency = "low" , logComments = List.unlines $ (map ((" * " <>) . List.intercalate "\n " . map unpack)) (fromMaybe [["Debianization generated by cabal-debian"]] (getL comments deb)) , logWho = show (pretty debianMaintainer) , logDate = date } -- Get the source package name, either from the SourcePackageName -- atom or construct it from the cabal package name. sourceName :: SrcPkgName sourceName = maybe (debianName deb Source' pkgId) id (getL sourcePackageName deb) merge :: ChangeLogEntry -> ChangeLogEntry -> ChangeLogEntry merge old new = old { logComments = logComments old ++ logComments new , logDate = date } debinfo = maybe (Right (epoch, fromMaybe "" (getL revision deb))) Left (getL debVersion deb) epoch = Map.lookup (pkgName pkgId) (getL epochMap deb) pkgId = Cabal.package pkgDesc pkgDesc = fromMaybe (error "versionInfo: no PackageDescription") $ getL packageDescription deb -- | Combine various bits of information to produce the debian version -- which will be used for the debian package. If the override -- parameter is provided this exact version will be used, but an error -- will be thrown if that version is unusably old - i.e. older than -- the cabal version of the package. Otherwise, the cabal version is -- combined with the given epoch number and revision string to create -- a version. convertVersion :: Either DebianVersion (Maybe Int, String) -> Version -> DebianVersion convertVersion debinfo cabalVersion = case debinfo of Left override | override >= parseDebianVersion (show (pretty cabalVersion)) -> override Left override -> error ("Version from --deb-version (" ++ show (pretty override) ++ ") is older than hackage version (" ++ show (pretty cabalVersion) ++ "), maybe you need to unpin this package?") Right (debianEpoch, debianRevision) -> buildDebianVersion debianEpoch (show (pretty cabalVersion)) (foldEmpty Nothing Just debianRevision) -- | Convert the extraLibs field of the cabal build info into debian -- binary package names and make them dependendencies of the debian -- devel package (if there is one.) addExtraLibDependencies :: Atoms -> Atoms addExtraLibDependencies deb = modL control (\ y -> y {binaryPackages = map f (binaryPackages (getL control deb))}) deb where f :: BinaryDebDescription -> BinaryDebDescription f bin | debianName deb Development (Cabal.package pkgDesc) == Debian.package bin = bin { relations = g (relations bin) } f bin = bin g :: Debian.PackageRelations -> Debian.PackageRelations g rels = rels { Debian.depends = concat $ [Debian.depends rels] ++ concatMap (\ cab -> maybe [[[Rel (BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]]] Set.toList (Map.lookup cab (getL extraLibMap deb))) (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc) } pkgDesc = fromMaybe (error "addExtraLibDependencies: no PackageDescription") $ getL packageDescription deb -- | Write the files of the debianization @d@ to the directory @top@. writeDebianization :: Top -> Atoms -> IO () writeDebianization top d = withCurrentDirectory (unTop top) $ mapM_ (\ (path, text) -> createDirectoryIfMissing True (takeDirectory path) >> replaceFile path (unpack text)) (Map.toList (toFileMap d)) >> getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True}) describeDebianization :: Atoms -> String describeDebianization atoms = concatMap (\ (path, text) -> path ++ ":\n" ++ indent " > " (unpack text)) (Map.toList (toFileMap atoms)) -- | Compare the existing debianization in @top@ to the generated one -- @new@, returning a string describing the differences. compareDebianization :: Atoms -> Atoms -> String compareDebianization old new = concat . Map.elems $ zipMaps doFile (toFileMap old) (toFileMap new) where doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String doFile path (Just _) Nothing = Just (path ++ ": Deleted\n") doFile path Nothing (Just n) = Just (path ++ ": Created\n" ++ indent " | " (unpack n)) doFile path (Just o) (Just n) = if o == n then Nothing -- Just (path ++ ": Unchanged\n") else Just (show (prettyDiff ("old" path) ("new" path) (contextDiff 2 (split (== '\n') o) (split (== '\n') n)))) doFile _path Nothing Nothing = error "Internal error in zipMaps" -- | Don't change anything, just make sure the new debianization -- matches the existing debianization in several particulars - -- specifically, version number, and source and binary package names. validateDebianization :: Atoms -> Atoms -> () validateDebianization old new = case () of _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion))) | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource))) | oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages))) | True -> () where oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog old)))) newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog new)))) oldSource = source . getL control $ old newSource = source . getL control $ new oldPackages = map Debian.package . binaryPackages . getL control $ old newPackages = map Debian.package . binaryPackages . getL control $ new unChangeLog :: ChangeLog -> [ChangeLogEntry] unChangeLog (ChangeLog x) = x cabal-debian-3.9/src/Debian/Debianize/ControlFile.hs0000644000175000017500000001757212236246354020423 0ustar dsfdsf-- | Preliminary. {-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-} module Debian.Debianize.ControlFile ( SourceDebDescription(..) , newSourceDebDescription , newSourceDebDescription' , VersionControlSpec(..) , XField(..) , XFieldDest(..) , BinaryDebDescription(..) , newBinaryDebDescription , modifyBinaryDeb -- , modifyBinaryDescription , PackageRelations(..) , PackageType(..) , packageArch ) where import Data.Generics (Data, Typeable) import Data.Monoid (mempty) import Data.Set as Set (Set, empty) import Data.Text (Text) import Debian.Orphans () import Debian.Policy (StandardsVersion, PackagePriority, PackageArchitectures(..), Section) import Debian.Relation (Relations, SrcPkgName(..), BinPkgName) import Prelude hiding (init, log) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) -- | This type represents the debian/control file, which is the core -- of the source package debianization. It includes the information -- that goes in the first, or source, section, and then a list of the -- succeeding binary package sections. data SourceDebDescription = SourceDebDescription { source :: Maybe SrcPkgName -- ^ , maintainer :: Maybe NameAddr -- ^ , changedBy :: Maybe NameAddr -- ^ , uploaders :: [NameAddr] -- ^ , dmUploadAllowed :: Bool -- ^ , priority :: Maybe PackagePriority -- ^ , section :: Maybe Section -- ^ , standardsVersion :: Maybe StandardsVersion -- ^ , homepage :: Maybe Text -- ^ , vcsFields :: Set VersionControlSpec -- ^ , xFields :: Set XField -- ^ , buildDepends :: Relations , buildConflicts :: Relations , buildDependsIndep :: Relations , buildConflictsIndep :: Relations , binaryPackages :: [BinaryDebDescription] -- This should perhaps be a set, or a map } deriving (Eq, Ord, Show, Data, Typeable) newSourceDebDescription :: SourceDebDescription newSourceDebDescription = SourceDebDescription { source = Nothing , maintainer = Nothing , changedBy = Nothing , uploaders = [] , dmUploadAllowed = False , priority = Nothing , section = Nothing , buildDepends = [] , buildConflicts = [] , buildDependsIndep = [] , buildConflictsIndep = [] , standardsVersion = Nothing , homepage = Nothing , vcsFields = Set.empty , xFields = Set.empty , binaryPackages = [] } newSourceDebDescription' :: SrcPkgName -> NameAddr -> SourceDebDescription newSourceDebDescription' src who = newSourceDebDescription { source = Just src , maintainer = Just who } data VersionControlSpec = VCSBrowser Text | VCSArch Text | VCSBzr Text | VCSCvs Text | VCSDarcs Text | VCSGit Text | VCSHg Text | VCSMtn Text | VCSSvn Text deriving (Eq, Ord, Show, Data, Typeable) -- | User defined fields. Parse the line "XBS-Comment: I stand -- between the candle and the star." to get XField (fromList "BS") -- "Comment" " I stand between the candle and the star." data XField = XField (Set XFieldDest) Text Text deriving (Eq, Ord, Show, Data, Typeable) data XFieldDest = B -- ^ Field will be copied to the binary packgae control files | S -- ^ Field will be copied to the source packgae control files | C -- ^ Field will be copied to the upload control (.changes) file deriving (Eq, Ord, Read, Show, Data, Typeable) -- | This type represents a section of the control file other than the -- first, which in turn represent one of the binary packages or debs -- produced by this debianization. data BinaryDebDescription = BinaryDebDescription { package :: BinPkgName -- ^ , architecture :: PackageArchitectures -- ^ , binarySection :: Maybe Section , binaryPriority :: Maybe PackagePriority , essential :: Bool -- ^ , description :: Text -- ^ , relations :: PackageRelations -- ^ } deriving (Eq, Ord, Read, Show, Data, Typeable) newBinaryDebDescription :: BinPkgName -> PackageArchitectures -> BinaryDebDescription newBinaryDebDescription name arch = BinaryDebDescription { package = name -- mkPkgName base typ , architecture = arch -- packageArch typ , binarySection = Nothing , binaryPriority = Nothing , essential = False , description = mempty , relations = newPackageRelations } -- | Modify the description of one of the binary debs without changing -- the package order. modifyBinaryDeb :: BinPkgName -> (Maybe BinaryDebDescription -> BinaryDebDescription) -> SourceDebDescription -> SourceDebDescription modifyBinaryDeb bin f deb = deb {binaryPackages = bins'} where bins' = if any (\ x -> package x == bin) bins then map g (binaryPackages deb) else binaryPackages deb ++ [f Nothing] g x = if package x == bin then f (Just x) else x bins = binaryPackages deb -- ^ Package interrelationship information. data PackageRelations = PackageRelations { depends :: Relations , recommends :: Relations , suggests :: Relations , preDepends :: Relations , breaks :: Relations , conflicts :: Relations , provides_ :: Relations , replaces_ :: Relations , builtUsing :: Relations } deriving (Eq, Ord, Read, Show, Data, Typeable) newPackageRelations :: PackageRelations newPackageRelations = PackageRelations { depends = [] , recommends = [] , suggests = [] , preDepends = [] , breaks = [] , conflicts = [] , provides_ = [] , replaces_ = [] , builtUsing = [] } -- ^ The different types of binary debs we can produce from a haskell package data PackageType = Development -- ^ The libghc-foo-dev package. | Profiling -- ^ The libghc-foo-prof package. | Documentation -- ^ The libghc-foo-doc package. | Exec -- ^ A package related to a particular executable, perhaps -- but not necessarily a server. | Utilities -- ^ A package that holds the package's data files -- and any executables not assigned to other -- packages. | Source' -- ^ The source package (not a binary deb actually.) | Cabal -- ^ This is used to construct the value for -- DEB_CABAL_PACKAGE in the rules file deriving (Eq, Show) packageArch :: PackageType -> PackageArchitectures packageArch Development = Any packageArch Profiling = Any packageArch Documentation = All packageArch Utilities = All packageArch Exec = Any packageArch Cabal = undefined packageArch Source' = undefined cabal-debian-3.9/src/Debian/Debianize/Bundled.hs0000644000175000017500000003146212236246354017552 0ustar dsfdsf-- | Determine whether a specific version of a Haskell package is -- bundled with into this particular version of the given compiler. {-# LANGUAGE StandaloneDeriving #-} module Debian.Debianize.Bundled ( ghcBuiltIn ) where import qualified Data.Map as Map import Data.Set (fromList, member) import Data.Version (Version(..)) import Debian.Relation.ByteString() import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), {-PackageDB(GlobalPackageDB), compilerFlavor-}) import Distribution.Package (PackageIdentifier(..), PackageName(..) {-, Dependency(..)-}) type Bundled = (CompilerFlavor, Version, [PackageIdentifier]) -- |Return a list of built in packages for the compiler in an environment. -- ghcBuiltIns :: FilePath -> IO [PackageIdentifier] -- ghcBuiltIns root = -- fchroot root (lazyProcess "ghc-pkg" ["list", "--simple-output"] Nothing Nothing empty) >>= -- return . map parsePackageIdentifier . words . unpack . fst . collectStdout -- where -- parsePackageIdentifier s = -- let (v', n') = break (== '-') (reverse s) -- (v, n) = (reverse (tail n'), reverse v') in -- PackageIdentifier (PackageName n) (Version (map read (filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) v))) []) ghcBuiltIns :: Compiler -> Bundled ghcBuiltIns (Compiler {compilerId = CompilerId GHC compilerVersion}) = case Map.lookup compilerVersion (Map.fromList (map (\ (cmp, ver, lst) -> (ver, (cmp, ver, lst))) [ (GHC, Version [7,6,3] [], ghc763BuiltIns) , (GHC, Version [7,6,2] [], ghc762BuiltIns) , (GHC, Version [7,6,1] [], ghc761BuiltIns) , (GHC, Version [7,6,1,20121207] [], ghc761BuiltIns) , (GHC, Version [7,4,1] [], ghc741BuiltIns) , (GHC, Version [7,4,0,20111219] [], ghc740BuiltIns) , (GHC, Version [7,4,0,20120108] [], ghc740BuiltIns) , (GHC, Version [7,2,2] [], ghc721BuiltIns) , (GHC, Version [7,2,1] [], ghc721BuiltIns) , (GHC, Version [7,0,4] [], ghc701BuiltIns) , (GHC, Version [7,0,3] [], ghc701BuiltIns) , (GHC, Version [7,0,1] [], ghc701BuiltIns) , (GHC, Version [6,8,3] [], ghc683BuiltIns) , (GHC, Version [6,8,2] [], ghc682BuiltIns) , (GHC, Version [6,8,1] [], ghc681BuiltIns) , (GHC, Version [6,6,1] [], ghc661BuiltIns) , (GHC, Version [6,6] [], ghc66BuiltIns) ])) of Nothing -> error $ "cabal-debian: No bundled package list for ghc " ++ show compilerVersion Just x -> x ghcBuiltIns (Compiler {compilerId = _}) = error "ghcBuiltIns: Only GHC is supported" ghcBuiltIn :: Compiler -> PackageName -> Bool ghcBuiltIn compiler package = Data.Set.member package (Data.Set.fromList (let {- (Just (_, _, xs)) = unsafePerformIO (ghc6BuiltIns compiler) -} (_, _, xs) = ghcBuiltIns compiler in map pkgName xs)) v :: String -> [Int] -> PackageIdentifier v n x = PackageIdentifier (PackageName n) (Version x []) ghc763BuiltIns :: [PackageIdentifier] ghc763BuiltIns = [ v "array" [0,4,0,1], v "base" [4,6,0,1], v "binary" [0,5,1,1], v "bin-package-db" [0,0,0,0], v "bytestring" [0,10,0,2], v "Cabal" [1,16,0], v "containers" [0,5,0,0], v "deepseq" [1,3,0,1], v "directory" [1,2,0,1], v "filepath" [1,3,0,1], v "ghc" [7,6,3], v "ghc-prim" [0,3,0,0], v "haskell2010" [1,1,1,0], v "haskell98" [2,0,0,2], v "hoopl" [3,9,0,0], v "hpc" [0,6,0,0], v "integer-gmp" [0,5,0,0], v "old-locale" [1,0,0,5], v "old-time" [1,1,0,1], v "pretty" [1,1,1,0], v "process" [1,1,0,2], v "template-haskell" [2,8,0,0], v "time" [1,4,0,1], v "unix" [2,6,0,1] ] -- Removed: rts, extensible-exceptions ghc762BuiltIns :: [PackageIdentifier] ghc762BuiltIns = [ v "array" [0,4,0,1], v "base" [4,6,0,1], v "binary" [0,5,1,1], v "bin-package-db" [0,0,0,0], v "bytestring" [0,10,0,2], v "Cabal" [1,16,0], v "containers" [0,5,0,0], v "deepseq" [1,3,0,1], v "directory" [1,2,0,1], v "filepath" [1,3,0,1], v "ghc" [7,6,2], v "ghc-prim" [0,3,0,0], v "haskell2010" [1,1,1,0], v "haskell98" [2,0,0,2], v "hoopl" [3,9,0,0], v "hpc" [0,6,0,0], v "integer-gmp" [0,5,0,0], v "old-locale" [1,0,0,5], v "old-time" [1,1,0,1], v "pretty" [1,1,1,0], v "process" [1,1,0,2], v "template-haskell" [2,8,0,0], v "time" [1,4,0,1], v "unix" [2,6,0,1] ] -- Removed: rts, extensible-exceptions ghc761BuiltIns :: [PackageIdentifier] ghc761BuiltIns = [ v "array" [0,4,0,1], v "base" [4,6,0,1], v "binary" [0,5,1,1], v "bin-package-db" [0,0,0,0], v "bytestring" [0,10,0,2], v "Cabal" [1,16,0], v "containers" [0,5,0,0], v "deepseq" [1,3,0,1], v "directory" [1,2,0,1], v "filepath" [1,3,0,1], v "ghc" [7,6,1,20121207], v "ghc-prim" [0,3,0,0], v "haskell2010" [1,1,1,0], v "haskell98" [2,0,0,2], v "hoopl" [3,9,0,0], v "hpc" [0,6,0,0], v "integer-gmp" [0,5,0,0], v "old-locale" [1,0,0,5], v "old-time" [1,1,0,1], v "pretty" [1,1,1,0], v "process" [1,1,0,2], v "template-haskell" [2,8,0,0], v "time" [1,4,0,1], v "unix" [2,6,0,1] ] -- | Packages bundled with 7.4.0.20111219-2. ghc741BuiltIns :: [PackageIdentifier] ghc741BuiltIns = [ v "Cabal" [1,14,0], v "array" [0,4,0,0], v "base" [4,5,0,0], v "bin-package-db" [0,0,0,0], v "binary" [0,5,1,0], v "bytestring" [0,9,2,1], v "containers" [0,4,2,1], v "deepseq" [1,3,0,0], v "directory" [1,1,0,2], v "extensible-exceptions" [0,1,1,4], v "filepath" [1,3,0,0], v "ghc" [7,4,1], v "ghc-prim" [0,2,0,0], v "haskell2010" [1,1,0,1], v "haskell98" [2,0,0,1], v "hoopl" [3,8,7,2], v "hpc" [0,5,1,1], v "integer-gmp" [0,4,0,0], v "old-locale" [1,0,0,4], v "old-time" [1,1,0,0], v "pretty" [1,1,1,0], v "process" [1,1,0,1], v "rts" [1,0], v "template-haskell" [2,7,0,0], v "time" [1,4], v "unix" [2,5,1,0] ] -- | Packages bundled with 7.4.0.20111219-2. ghc740BuiltIns :: [PackageIdentifier] ghc740BuiltIns = [ v "Cabal" [1,14,0], v "array" [0,4,0,0], v "base" [4,5,0,0], v "bin-package-db" [0,0,0,0], v "binary" [0,5,1,0], v "bytestring" [0,9,2,1], v "containers" [0,4,2,1], v "deepseq" [1,3,0,0], v "directory" [1,1,0,2], v "extensible-exceptions" [0,1,1,4], v "filepath" [1,3,0,0], v "ghc" [7,4,0,20111219], v "ghc-prim" [0,2,0,0], v "haskell2010" [1,1,0,1], v "haskell98" [2,0,0,1], v "hoopl" [3,8,7,2], v "hpc" [0,5,1,1], v "integer-gmp" [0,4,0,0], v "old-locale" [1,0,0,4], v "old-time" [1,1,0,0], v "pretty" [1,1,1,0], v "process" [1,1,0,1], v "rts" [1,0], v "template-haskell" [2,7,0,0], v "time" [1,4], v "unix" [2,5,1,0] ] ghc721BuiltIns :: [PackageIdentifier] ghc721BuiltIns = [ v "Cabal" [1,12,0], v "array" [0,3,0,3], v "base" [4,4,0,0], v "bin-package-db" [0,0,0,0], v "binary" [0,5,0,2], v "bytestring" [0,9,2,0], v "containers" [0,4,1,0], v "directory" [1,1,0,1], v "extensible-exceptions" [0,1,1,3], v "filepath" [1,2,0,1], v "ghc" [7,2,1], -- ghc-binary renamed to binary v "ghc-prim" [0,2,0,0], v "haskell2010" [1,1,0,0], v "haskell98" [2,0,0,0], v "hoopl" [3,8,7,1], -- new v "hpc" [0,5,1,0], v "integer-gmp" [0,3,0,0], v "old-locale" [1,0,0,3], v "old-time" [1,0,0,7], v "pretty" [1,1,0,0], v "process" [1,1,0,0], -- random removed v "rts" [1,0], v "template-haskell" [2,6,0,0], v "time" [1,2,0,5], v "unix" [2,5,0,0] ] ghc701BuiltIns :: [PackageIdentifier] ghc701BuiltIns = [ v "Cabal" [1,10,0,0], v "array" [0,3,0,2], v "base" [4,3,0,0], v "bin-package-db" [0,0,0,0], v "bytestring" [0,9,1,8], v "containers" [0,4,0,0], v "directory" [1,1,0,0], v "extensible-exceptions" [0,1,1,2], v "filepath" [1,2,0,0], v "ghc" [7,0,1], v "ghc-binary" [0,5,0,2], v "ghc-prim" [0,2,0,0], v "haskell2010" [1,0,0,0], v "haskell98" [1,1,0,0], v "hpc" [0,5,0,6], v "integer-gmp" [0,2,0,2], v "old-locale" [1,0,0,2], v "old-time" [1,0,0,6], v "pretty" [1,0,1,2], v "process" [1,0,1,4], v "random" [1,0,0,3], v "rts" [1,0], v "template-haskell" [2,5,0,0], v "time" [1,2,0,3], v "unix" [2,4,1,0] ] ghc683BuiltIns :: [PackageIdentifier] ghc683BuiltIns = ghc682BuiltIns ghc682BuiltIns :: [PackageIdentifier] ghc682BuiltIns = [ v "Cabal" [1,2,3,0], v "array" [0,1,0,0], v "base" [3,0,1,0], v "bytestring" [0,9,0,1], v "containers" [0,1,0,1], v "directory" [1,0,0,0], v "filepath" [1,1,0,0], v "ghc" [6,8,2,0], v "haskell98" [1,0,1,0], v "hpc" [0,5,0,0], v "old-locale" [1,0,0,0], v "old-time" [1,0,0,0], v "packedstring" [0,1,0,0], v "pretty" [1,0,0,0], v "process" [1,0,0,0], v "random" [1,0,0,0], v "readline" [1,0,1,0], v "template-haskell" [2,2,0,0], v "unix" [2,3,0,0] ] ghc681BuiltIns :: [PackageIdentifier] ghc681BuiltIns = [ v "base" [3,0,0,0], v "Cabal" [1,2,2,0], v "GLUT" [2,1,1,1], v "HGL" [3,2,0,0], v "HUnit" [1,2,0,0], v "OpenAL" [1,3,1,1], v "OpenGL" [2,2,1,1], v "QuickCheck" [1,1,0,0], v "X11" [1,2,3,1], v "array" [0,1,0,0], v "bytestring" [0,9,0,1], v "cgi" [3001,1,5,1], v "containers" [0,1,0,0], v "directory" [1,0,0,0], v "fgl" [5,4,1,1], v "filepatch" [1,1,0,0], v "ghc" [6,8,1,0], v "haskell-src" [1,0,1,1], v "haskell98" [1,0,1,0], v "hpc" [0,5,0,0], v "html" [1,0,1,1], v "mtl" [1,1,0,0], v "network" [2,1,0,0], v "old-locale" [1,0,0,0], v "old-time" [1,0,0,0], v "packedstring" [0,1,0,0], v "parallel" [1,0,0,0], v "parsec" [2,1,0,0], v "pretty" [1,0,0,0], v "process" [1,0,0,0], v "random" [1,0,0,0], v "readline" [1,0,1,0], v "regex-base" [0,72,0,1], v "regex-compat" [0,71,0,1], v "regex-posix" [0,72,0,1], v "stm" [2,1,1,0], v "template-haskell" [2,2,0,0], v "time" [1,1,2,0], v "unix" [2,2,0,0], v "xhtml" [3000,0,2,1] ] ghc661BuiltIns :: [PackageIdentifier] ghc661BuiltIns = [ v "base" [2,1,1], v "Cabal" [1,1,6,2], v "cgi" [3001,1,1], v "fgl" [5,4,1], v "filepath" [1,0], v "ghc" [6,6,1], v "GLUT" [2,1,1], v "haskell98" [1,0], v "haskell-src" [1,0,1], v "HGL" [3,1,1], v "html" [1,0,1], v "HUnit" [1,1,1], v "mtl" [1,0,1], v "network" [2,0,1], v "OpenAL" [1,3,1], v "OpenGL" [2,2,1], v "parsec" [2,0], v "QuickCheck" [1,0,1], v "readline" [1,0], v "regex-base" [0,72], v "regex-compat" [0,71], v "regex-posix" [0,71], v "rts" [1,0], v "stm" [2,0], v "template-haskell" [2,1], v "time" [1,1,1], v "unix" [2,1], v "X11" [1,2,1], v "xhtml" [3000,0,2] ] ghc66BuiltIns :: [PackageIdentifier] ghc66BuiltIns = [ v "base" [2,0], v "Cabal" [1,1,6], v "cgi" [2006,9,6], v "fgl" [5,2], v "ghc" [6,6], v "GLUT" [2,0], v "haskell98" [1,0], v "haskell-src" [1,0], v "HGL" [3,1], v "html" [1,0], v "HTTP" [2006,7,7], v "HUnit" [1,1], v "mtl" [1,0], v "network" [2,0], v "OpenAL" [1,3], v "OpenGL" [2,1], v "parsec" [2,0], v "QuickCheck" [1,0], v "readline" [1,0], v "regex-base" [0,71], v "regex-compat" [0,71], v "regex-posix" [0,71], v "rts" [1,0], v "stm" [2,0], v "template-haskell" [2,0], v "time" [1,0], v "unix" [1,0], v "X11" [1,1], v "xhtml" [2006,9,13] ] -- Script to output a list of the libraries in the ghc package -- provides line. This could be run inside the build environment -- instead of having these hard coded lists. -- -- apt-cache show ghc \ -- | grep ^Provides: \ -- | cut -d\ -f2- -- | sed 's/, /\n/g' \ -- | grep libghc- \ -- | cut -d- -f2- \ -- | grep dev$ \ -- | sort -u \ -- | sed 's/-dev//;s/$/",/;s/^/"/' -- -- base :: Set String -- base -- = Data.Set.fromList -- [ "array", -- "base", -- "binary", -- "bin-package-db", -- "bytestring", -- "cabal", -- "containers", -- "deepseq", -- "directory", -- "extensible-exceptions", -- "filepath", -- "ghc-prim", -- "haskell2010", -- "haskell98", -- "hoopl", -- "hpc", -- "integer-gmp", -- "old-locale", -- "old-time", -- "pretty", -- "process", -- "rts", -- "template-haskell", -- "time", -- "unix" ] cabal-debian-3.9/src/Debian/Debianize/Input.hs0000644000175000017500000004567612236246354017310 0ustar dsfdsf-- | Read an existing Debianization from a directory file. {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.Debianize.Input ( inputDebianization , inputDebianizationFile , inputChangeLog , inputCabalization , inputLicenseFile , inputMaintainer ) where import Debug.Trace (trace) import Control.Exception (bracket) import Control.Monad (when, foldM, filterM) import Control.Monad.Trans (MonadIO, liftIO) import Data.Char (isSpace) import Data.Lens.Lazy (getL, setL, modL) import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe, fromJust) import Data.Monoid (mempty) import Data.Set as Set (toList, fromList, insert, union, singleton) import Data.Text (Text, unpack, pack, lines, words, break, strip, null) import Data.Text.IO (readFile) import Debian.Changes (ChangeLog(..), parseChangeLog) import Debian.Control (Control'(unControl), Paragraph'(..), stripWS, parseControlFromFile, Field, Field'(..), ControlFunctions) import Debian.Debianize.Atoms as Atoms (Atoms, rulesHead, compat, sourceFormat, watch, changelog, control, copyright, intermediateFiles, postInst, postRm, preInst, preRm, install, installDir, warning, logrotateStanza, installInit, link, packageDescription, compiler, maintainer, verbosity, compilerVersion, cabalFlagAssignments) import Debian.Debianize.ControlFile (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..), XField(..), newSourceDebDescription', newBinaryDebDescription) import Debian.Debianize.Types (Top(Top, unTop)) import Debian.Debianize.Utility (getDirectoryContents', withCurrentDirectory, readFileMaybe, read') import Debian.Orphans () import Debian.Policy (Section(..), parseStandardsVersion, readPriority, readSection, parsePackageArchitectures, parseMaintainer, parseUploaders, readSourceFormat, getDebianMaintainer, haskellMaintainer) import Debian.Relation (Relations, BinPkgName(..), SrcPkgName(..), parseRelations) import Distribution.Package (Package(packageId)) import Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, maintainer)) import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..), Compiler(..)) import Distribution.Simple.Configure (configCompiler) import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Utils (defaultPackageDesc, die, setupMessage) import Distribution.System (Platform(..), buildOS, buildArch) import Distribution.Verbosity (Verbosity, intToVerbosity) import Prelude hiding (readFile, lines, words, break, null, log, sum) import System.Cmd (system) import System.Directory (doesFileExist) import System.Exit (ExitCode(..)) import System.FilePath ((), takeExtension, dropExtension) import System.Posix.Files (setFileCreationMask) import System.IO.Error (catchIOError) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) inputDebianization :: Top -> IO Atoms inputDebianization top = do (ctl, _) <- inputSourceDebDescription top atoms <- inputAtomsFromDirectory top mempty return $ modL control (const ctl) atoms -- | Try to input a file and if successful add it to the debianization. inputDebianizationFile :: Top -> FilePath -> Atoms -> IO Atoms inputDebianizationFile (Top top) path atoms = readFileMaybe (top path) >>= return . maybe atoms (\ text -> modL intermediateFiles (insert (path, text)) atoms) inputSourceDebDescription :: Top -> IO (SourceDebDescription, [Field]) inputSourceDebDescription top = do paras <- parseControlFromFile (unTop top "debian/control") >>= either (error . show) (return . unControl) case paras of [] -> error "Missing source paragraph" [_] -> error "Missing binary paragraph" (hd : tl) -> return $ parseSourceDebDescription hd tl parseSourceDebDescription :: Paragraph' String -> [Paragraph' String] -> (SourceDebDescription, [Field]) parseSourceDebDescription (Paragraph fields) binaryParagraphs = foldr readField (src, []) fields' where fields' = map stripField fields src = (newSourceDebDescription' findSource findMaint) {binaryPackages = bins} findSource = findMap "Source" SrcPkgName fields' findMaint = findMap "Maintainer" (\ m -> either (\ e -> error $ "Failed to parse maintainer field " ++ show m ++ ": " ++ show e) id . parseMaintainer $ m) fields' -- findStandards = findMap "Standards-Version" parseStandardsVersion fields' (bins, _extra) = unzip $ map parseBinaryDebDescription binaryParagraphs readField :: Field -> (SourceDebDescription, [Field]) -> (SourceDebDescription, [Field]) -- Mandatory readField (Field ("Source", _)) x = x readField (Field ("Maintainer", _)) x = x -- readField (Field ("Standards-Version", _)) x = x -- Recommended readField (Field ("Standards-Version", value)) (desc, unrecognized) = (desc {standardsVersion = Just (parseStandardsVersion value)}, unrecognized) readField (Field ("Priority", value)) (desc, unrecognized) = (desc {priority = Just (readPriority value)}, unrecognized) readField (Field ("Section", value)) (desc, unrecognized) = (desc {section = Just (MainSection value)}, unrecognized) -- Optional readField (Field ("Homepage", value)) (desc, unrecognized) = (desc {homepage = Just (strip (pack value))}, unrecognized) readField (Field ("Uploaders", value)) (desc, unrecognized) = (desc {uploaders = either (const []) id (parseUploaders value)}, unrecognized) readField (Field ("DM-Upload-Allowed", value)) (desc, unrecognized) = (desc {dmUploadAllowed = yes value}, unrecognized) readField (Field ("Build-Depends", value)) (desc, unrecognized) = (desc {buildDepends = rels value}, unrecognized) readField (Field ("Build-Conflicts", value)) (desc, unrecognized) = (desc {buildConflicts = rels value}, unrecognized) readField (Field ("Build-Depends-Indep", value)) (desc, unrecognized) = (desc {buildDependsIndep = rels value}, unrecognized) readField (Field ("Build-Conflicts-Indep", value)) (desc, unrecognized) = (desc {buildConflictsIndep = rels value}, unrecognized) readField (Field ("Vcs-Browser", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBrowser (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Arch", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSArch (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Bzr", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSBzr (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Cvs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSCvs (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Darcs", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSDarcs (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Git", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSGit (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Hg", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSHg (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Mtn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSMtn (pack s)) (vcsFields desc)}, unrecognized) readField (Field ("Vcs-Svn", s)) (desc, unrecognized) = (desc {vcsFields = insert (VCSSvn (pack s)) (vcsFields desc)}, unrecognized) readField field@(Field ('X' : fld, value)) (desc, unrecognized) = case span (`elem` "BCS") fld of (xs, '-' : more) -> (desc {xFields = insert (XField (fromList (map (read' (\ s -> error $ "parseSourceDebDescription: " ++ show s) . (: [])) xs)) (pack more) (pack value)) (xFields desc)}, unrecognized) _ -> (desc, field : unrecognized) readField field (desc, unrecognized) = (desc, field : unrecognized) parseBinaryDebDescription :: Paragraph' String -> (BinaryDebDescription, [Field]) parseBinaryDebDescription (Paragraph fields) = foldr readField (bin, []) fields' where fields' = map stripField fields bin = newBinaryDebDescription findPackage findArchitecture findPackage = findMap "Package" BinPkgName fields' findArchitecture = findMap "Architecture" parsePackageArchitectures fields' {- (BinPkgName (fromJust (fieldValue "Package" bin))) (read' (fromJust (fieldValue "Architecture" bin))) , [] foldr readField (newBinaryDebDescription (BinPkgName (fromJust (fieldValue "Package" bin))) (read' (fromJust (fieldValue "Architecture" bin))), []) (map stripField fields) -} readField :: Field -> (BinaryDebDescription, [Field]) -> (BinaryDebDescription, [Field]) readField (Field ("Package", value)) (desc, unrecognized) = (desc {package = BinPkgName value}, unrecognized) readField (Field ("Architecture", value)) (desc, unrecognized) = (desc {architecture = parsePackageArchitectures value}, unrecognized) readField (Field ("Section", value)) (desc, unrecognized) = (desc {binarySection = Just (readSection value)}, unrecognized) readField (Field ("Priority", value)) (desc, unrecognized) = (desc {binaryPriority = Just (readPriority value)}, unrecognized) readField (Field ("Essential", value)) (desc, unrecognized) = (desc {essential = yes value}, unrecognized) readField (Field ("Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {depends = rels value}}, unrecognized) readField (Field ("Recommends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {recommends = rels value}}, unrecognized) readField (Field ("Suggests", value)) (desc, unrecognized) = (desc {relations = (relations desc) {suggests = rels value}}, unrecognized) readField (Field ("Pre-Depends", value)) (desc, unrecognized) = (desc {relations = (relations desc) {preDepends = rels value}}, unrecognized) readField (Field ("Breaks", value)) (desc, unrecognized) = (desc {relations = (relations desc) {breaks = rels value}}, unrecognized) readField (Field ("Conflicts", value)) (desc, unrecognized) = (desc {relations = (relations desc) {conflicts = rels value}}, unrecognized) readField (Field ("Provides", value)) (desc, unrecognized) = (desc {relations = (relations desc) {provides_ = rels value}}, unrecognized) readField (Field ("Replaces", value)) (desc, unrecognized) = (desc {relations = (relations desc) {replaces_ = rels value}}, unrecognized) readField (Field ("Built-Using", value)) (desc, unrecognized) = (desc {relations = (relations desc) {builtUsing = rels value}}, unrecognized) readField (Field ("Description", value)) (desc, unrecognized) = (desc {description = pack value}, unrecognized) readField field (desc, unrecognized) = (desc, field : unrecognized) -- | Look for a field and apply a function to its value findMap :: String -> (String -> a) -> [Field] -> a findMap field f fields = fromMaybe (error $ "Missing " ++ show field ++ " field in " ++ show fields) (foldr findMap' Nothing fields) where findMap' (Field (fld, val)) x = if fld == field then Just (f val) else x findMap' _ x = x stripField :: ControlFunctions a => Field' a -> Field' a stripField (Field (a, b)) = Field (a, stripWS b) stripField x = x rels :: String -> Relations rels s = either (\ e -> error ("Relations field error: " ++ show e ++ "\n " ++ s)) id (parseRelations s) yes :: String -> Bool yes "yes" = True yes "no" = False yes x = error $ "Expecting yes or no: " ++ x inputChangeLog :: Top -> IO ChangeLog inputChangeLog (Top top) = readFile (top "debian/changelog") >>= return . parseChangeLog . unpack inputAtomsFromDirectory :: Top -> Atoms -> IO Atoms -- .install files, .init files, etc. inputAtomsFromDirectory top xs = findFiles xs >>= doFiles (unTop top "debian/cabalInstall") where findFiles :: Atoms -> IO Atoms findFiles xs' = getDirectoryContents' (unTop top "debian") >>= return . (++ ["source/format"]) >>= filterM (doesFileExist . ((unTop top "debian") )) >>= foldM (\ xs'' name -> inputAtoms (unTop top "debian") name xs'') xs' doFiles :: FilePath -> Atoms -> IO Atoms doFiles tmp xs' = do sums <- getDirectoryContents' tmp `catchIOError` (\ _ -> return []) paths <- mapM (\ sum -> getDirectoryContents' (tmp sum) >>= return . map (sum )) sums >>= return . filter ((/= '~') . last) . concat files <- mapM (readFile . (tmp )) paths foldM (\ xs'' (path, file) -> return $ modL intermediateFiles (Set.insert ("debian/cabalInstall" path, file)) xs'') xs' (zip paths files) inputAtoms :: FilePath -> FilePath -> Atoms -> IO Atoms inputAtoms _ path xs | elem path ["control"] = return xs inputAtoms debian name@"source/format" xs = readFile (debian name) >>= \ text -> return $ (either (modL warning . Set.insert) (setL sourceFormat . Just) (readSourceFormat text)) xs inputAtoms debian name@"watch" xs = readFile (debian name) >>= \ text -> return $ setL watch (Just text) xs inputAtoms debian name@"rules" xs = readFile (debian name) >>= \ text -> return $ setL rulesHead (Just text) xs inputAtoms debian name@"compat" xs = readFile (debian name) >>= \ text -> return $ setL compat (Just (read' (\ s -> error $ "compat: " ++ show s) (unpack text))) xs inputAtoms debian name@"copyright" xs = readFile (debian name) >>= \ text -> return $ setL copyright (Just (Right text)) xs inputAtoms debian name@"changelog" xs = readFile (debian name) >>= return . parseChangeLog . unpack >>= \ log -> return $ setL changelog (Just log) xs inputAtoms debian name xs = case (BinPkgName (dropExtension name), takeExtension name) of (p, ".install") -> readFile (debian name) >>= \ text -> return $ foldr (readInstall p) xs (lines text) (p, ".dirs") -> readFile (debian name) >>= \ text -> return $ foldr (readDir p) xs (lines text) (p, ".init") -> readFile (debian name) >>= \ text -> return $ modL installInit (insertWith (error "inputAtoms") p text) xs (p, ".logrotate") -> readFile (debian name) >>= \ text -> return $ modL logrotateStanza (insertWith Set.union p (singleton text)) xs (p, ".links") -> readFile (debian name) >>= \ text -> return $ foldr (readLink p) xs (lines text) (p, ".postinst") -> readFile (debian name) >>= \ text -> return $ modL postInst (insertWith (error "inputAtoms") p text) xs (p, ".postrm") -> readFile (debian name) >>= \ text -> return $ modL postRm (insertWith (error "inputAtoms") p text) xs (p, ".preinst") -> readFile (debian name) >>= \ text -> return $ modL preInst (insertWith (error "inputAtoms") p text) xs (p, ".prerm") -> readFile (debian name) >>= \ text -> return $ modL preRm (insertWith (error "inputAtoms") p text) xs (_, ".log") -> return xs -- Generated by debhelper (_, ".debhelper") -> return xs -- Generated by debhelper (_, ".hs") -> return xs -- Code that uses this library (_, ".setup") -> return xs -- Compiled Setup.hs file (_, ".substvars") -> return xs -- Unsupported (_, "") -> return xs -- File with no extension (_, x) | last x == '~' -> return xs -- backup file _ -> trace ("Ignored: " ++ debian name) (return xs) readLink :: BinPkgName -> Text -> Atoms -> Atoms readLink p line atoms = case words line of [a, b] -> modL link (insertWith Set.union p (singleton (unpack a, unpack b))) atoms [] -> atoms _ -> trace ("readLink: " ++ show line) atoms readInstall :: BinPkgName -> Text -> Atoms -> Atoms readInstall p line atoms = case break isSpace line of (_, b) | null b -> error $ "readInstall: syntax error in .install file for " ++ show p ++ ": " ++ show line (a, b) -> modL install (insertWith union p (singleton (unpack (strip a), unpack (strip b)))) atoms readDir :: BinPkgName -> Text -> Atoms -> Atoms readDir p line atoms = modL installDir (insertWith union p (singleton (unpack line))) atoms inputCabalization :: Top -> Atoms -> IO Atoms inputCabalization top atoms = withCurrentDirectory (unTop top) $ do descPath <- defaultPackageDesc vb genPkgDesc <- readPackageDescription vb descPath (compiler', _) <- configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration vb let compiler'' = case getL compilerVersion atoms of (Just ver) -> compiler' {compilerId = CompilerId GHC ver} _ -> compiler' case finalizePackageDescription (toList (getL cabalFlagAssignments atoms)) (const True) (Platform buildArch buildOS) (compilerId compiler'') [] genPkgDesc of Left e -> error $ "Failed to load cabal package description: " ++ show e Right (pkgDesc, _) -> do liftIO $ bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc return $ setL compiler (Just compiler'') $ setL packageDescription (Just pkgDesc) $ atoms where vb = intToVerbosity' (getL verbosity atoms) -- | Run the package's configuration script. autoreconf :: Verbosity -> PackageDescription -> IO () autoreconf verbose pkgDesc = do ac <- doesFileExist "configure.ac" when ac $ do c <- doesFileExist "configure" when (not c) $ do setupMessage verbose "Running autoreconf" (packageId pkgDesc) ret <- system "autoreconf" case ret of ExitSuccess -> return () ExitFailure n -> die ("autoreconf failed with status " ++ show n) -- | Try to read the license file specified in the cabal package, -- otherwise return a text representation of the License field. inputLicenseFile :: PackageDescription -> IO (Maybe Text) inputLicenseFile pkgDesc = readFileMaybe (licenseFile pkgDesc) -- | Try to compute the debian maintainer from the maintainer field of the -- cabal package, or from the value returned by getDebianMaintainer. inputMaintainer :: Atoms -> IO (Maybe NameAddr) inputMaintainer atoms = debianPackageMaintainer >>= maybe cabalPackageMaintainer (return . Just) >>= maybe getDebianMaintainer (return . Just) >>= return . maybe (Just haskellMaintainer) Just where debianPackageMaintainer :: IO (Maybe NameAddr) debianPackageMaintainer = return (getL Atoms.maintainer atoms) cabalPackageMaintainer :: IO (Maybe NameAddr) cabalPackageMaintainer = return $ case fmap Cabal.maintainer (getL packageDescription atoms) of Nothing -> Nothing Just "" -> Nothing Just x -> either (const Nothing) Just (parseMaintainer (takeWhile (\ c -> c /= ',' && c /= '\n') x)) intToVerbosity' :: Int -> Verbosity intToVerbosity' n = fromJust (intToVerbosity (max 0 (min 3 n))) cabal-debian-3.9/src/Debian/Debianize/Dependencies.hs0000644000175000017500000004745212236246354020571 0ustar dsfdsf{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-} {-# OPTIONS -Wall -Wwarn -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Debianize.Dependencies ( cabalDependencies -- Debian.Cabal.SubstVars , selfDependency -- Debian.Debianize.Combinators , allBuildDepends , debDeps , putBuildDeps , dependencies , debianName , debianName' , debNameFromType , getRulesHead , filterMissing , binaryPackageDeps , binaryPackageConflicts , binaryPackageProvides , binaryPackageReplaces ) where import Data.Char (isSpace, toLower) import Data.Function (on) import Data.Lens.Lazy (getL, modL) import Data.List as List (nub, minimumBy, isSuffixOf, map) import Data.Map as Map (Map, lookup) import Data.Maybe (fromMaybe, catMaybes, listToMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text as Text (Text, pack, unlines) import Data.Version (showVersion) import Debian.Control import Debian.Debianize.Atoms (Atoms, packageDescription, rulesHead, compiler, noProfilingLibrary, noDocumentationLibrary, missingDependencies, debianNameMap, extraLibMap, buildDeps, buildDepsIndep, execMap, epochMap, packageInfo, depends, conflicts, provides, replaces, control) import Debian.Debianize.Bundled (ghcBuiltIn) import Debian.Debianize.ControlFile as Debian (PackageType(..), SourceDebDescription(..)) import Debian.Debianize.Types (PackageInfo(devDeb, profDeb, docDeb), DebType(..)) import Debian.Debianize.Types.VersionSplits (VersionSplits, doSplits, packageRangesFromVersionSplits) import Debian.Orphans () import qualified Debian.Relation as D import Debian.Relation (Relations, Relation, BinPkgName(BinPkgName), PkgName(pkgNameFromString)) import Debian.Version (parseDebianVersion) import Distribution.Package (PackageName(PackageName), PackageIdentifier(..), Dependency(..)) import Distribution.PackageDescription as Cabal (PackageDescription(..), allBuildInfo, buildTools, pkgconfigDepends, extraLibs) import Distribution.Version (VersionRange, anyVersion, foldVersionRange', intersectVersionRanges, unionVersionRanges, laterVersion, orLaterVersion, earlierVersion, orEarlierVersion, fromVersionIntervals, toVersionIntervals, withinVersion, isNoVersion, asVersionIntervals) import Distribution.Version.Invert (invertVersionRange) import Prelude hiding (unlines) import System.Exit (ExitCode(ExitSuccess)) import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcessWithExitCode) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) data Dependency_ = BuildDepends Dependency | BuildTools Dependency | PkgConfigDepends Dependency | ExtraLibs Relations deriving (Eq, Show) -- | In cabal a self dependency probably means the library is needed -- while building the executables. In debian it would mean that the -- package needs an earlier version of itself to build, so we use this -- to filter such dependencies out. selfDependency :: PackageIdentifier -> Dependency_ -> Bool selfDependency pkgId (BuildDepends (Dependency name _)) = name == pkgName pkgId selfDependency _ _ = False unboxDependency :: Dependency_ -> Maybe Dependency unboxDependency (BuildDepends d) = Just d unboxDependency (BuildTools d) = Just d unboxDependency (PkgConfigDepends d) = Just d unboxDependency (ExtraLibs _) = Nothing -- Dependency (PackageName d) anyVersion -- Make a list of the debian devel packages corresponding to cabal packages -- which are build dependencies debDeps :: DebType -> Atoms -> Control' String -> D.Relations debDeps debType atoms control = interdependencies ++ otherdependencies where interdependencies = case debType of Prof -> maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) (debNameFromType control Dev) _ -> [] otherdependencies = catMaybes (map (\ (Dependency name _) -> case Map.lookup name (getL packageInfo atoms) of Just p -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (case debType of Dev -> devDeb p Prof -> profDeb p Doc -> docDeb p) Nothing -> Nothing) (cabalDependencies atoms)) cabalDependencies :: Atoms -> [Dependency] cabalDependencies atoms = catMaybes $ map unboxDependency $ allBuildDepends atoms (Cabal.buildDepends (fromMaybe (error "cabalDependencies") $ getL packageDescription atoms)) (concatMap buildTools . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) (concatMap pkgconfigDepends . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) (concatMap extraLibs . allBuildInfo . fromMaybe (error "cabalDependencies") $ getL packageDescription atoms) -- |Debian packages don't have per binary package build dependencies, -- so we just gather them all up here. allBuildDepends :: Atoms -> [Dependency] -> [Dependency] -> [Dependency] -> [String] -> [Dependency_] allBuildDepends atoms buildDepends buildTools pkgconfigDepends extraLibs = nub $ map BuildDepends buildDepends ++ map BuildTools buildTools ++ map PkgConfigDepends pkgconfigDepends ++ map ExtraLibs (fixDeps extraLibs) where fixDeps :: [String] -> [Relations] fixDeps xs = concatMap (\ cab -> maybe [[[D.Rel (D.BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]]] Set.toList (Map.lookup cab (getL extraLibMap atoms))) xs putBuildDeps :: Atoms -> Atoms putBuildDeps deb = modL control (\ y -> y { Debian.buildDepends = debianBuildDeps deb, buildDependsIndep = debianBuildDepsIndep deb }) deb -- The haskell-cdbs package contains the hlibrary.mk file with -- the rules for building haskell packages. debianBuildDeps :: Atoms -> D.Relations debianBuildDeps deb = filterMissing deb $ nub $ [[D.Rel (D.BinPkgName "debhelper") (Just (D.GRE (parseDebianVersion ("7.0" :: String)))) Nothing], [D.Rel (D.BinPkgName "haskell-devscripts") (Just (D.GRE (parseDebianVersion ("0.8" :: String)))) Nothing], anyrel "cdbs", anyrel "ghc"] ++ concat (Set.toList (getL buildDeps deb)) ++ (if getL noProfilingLibrary deb then [] else [anyrel "ghc-prof"]) ++ cabalDeps (getL packageDescription deb) where cabalDeps Nothing = [] cabalDeps (Just pkgDesc) = (concat $ map (buildDependencies deb) $ filter (not . selfDependency (Cabal.package pkgDesc)) $ allBuildDepends deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc)) debianBuildDepsIndep :: Atoms -> D.Relations debianBuildDepsIndep deb = filterMissing deb $ if getL noDocumentationLibrary deb then [] else nub $ [anyrel "ghc-doc"] ++ concat (Set.toList (getL buildDepsIndep deb)) ++ cabalDeps (getL packageDescription deb) where cabalDeps Nothing = [] cabalDeps (Just pkgDesc) = (concat . map (docDependencies deb) $ filter (not . selfDependency (Cabal.package pkgDesc)) $ allBuildDepends deb (Cabal.buildDepends pkgDesc) (concatMap buildTools . allBuildInfo $ pkgDesc) (concatMap pkgconfigDepends . allBuildInfo $ pkgDesc) (concatMap extraLibs . allBuildInfo $ pkgDesc)) -- | The documentation dependencies for a package include the -- documentation package for any libraries which are build -- dependencies, so we have access to all the cross references. docDependencies :: Atoms -> Dependency_ -> D.Relations docDependencies atoms (BuildDepends (Dependency name ranges)) = dependencies atoms Documentation name ranges docDependencies _ _ = [] -- | The Debian build dependencies for a package include the profiling -- libraries and the documentation packages, used for creating cross -- references. Also the packages associated with extra libraries. buildDependencies :: Atoms -> Dependency_ -> D.Relations buildDependencies atoms (BuildDepends (Dependency name ranges)) = dependencies atoms Development name ranges ++ dependencies atoms Profiling name ranges buildDependencies atoms dep@(ExtraLibs _) = concat (adapt (getL execMap atoms) dep) buildDependencies atoms dep = case unboxDependency dep of Just (Dependency _name _ranges) -> concat (adapt (getL execMap atoms) dep) Nothing -> [] adapt :: Map.Map String Relations -> Dependency_ -> [Relations] adapt execMap (PkgConfigDepends (Dependency (PackageName pkg) _)) = maybe (aptFile pkg) (: []) (Map.lookup pkg execMap) adapt execMap (BuildTools (Dependency (PackageName pkg) _)) = maybe (aptFile pkg) (: []) (Map.lookup pkg execMap) adapt _flags (ExtraLibs x) = [x] adapt _flags (BuildDepends (Dependency (PackageName pkg) _)) = [[[D.Rel (D.BinPkgName pkg) Nothing Nothing]]] -- There are two reasons this may not work, or may work -- incorrectly: (1) the build environment may be a different -- distribution than the parent environment (the environment the -- autobuilder was run from), so the packages in that -- environment might have different names, and (2) the package -- we are looking for may not be installed in the parent -- environment. aptFile :: String -> [Relations] -- Maybe would probably be more correct aptFile pkg = unsafePerformIO $ do ret <- readProcessWithExitCode "apt-file" ["-l", "search", pkg ++ ".pc"] "" return $ case ret of (ExitSuccess, out, _) -> case takeWhile (not . isSpace) out of "" -> error $ "Unable to locate a package containing " ++ pkg ++ ", try using --exec-map " ++ pkg ++ "= or modL execMap (Map.insert (PackageName " ++ show pkg ++ ") (BinPkgName \"\")" s -> [[[D.Rel (D.BinPkgName s) Nothing Nothing]]] _ -> [] anyrel :: String -> [D.Relation] anyrel x = anyrel' (D.BinPkgName x) anyrel' :: D.BinPkgName -> [D.Relation] anyrel' x = [D.Rel x Nothing Nothing] -- | Turn a cabal dependency into debian dependencies. The result -- needs to correspond to a single debian package to be installed, -- so we will return just an OrRelation. dependencies :: Atoms -> PackageType -> PackageName -> VersionRange -> Relations dependencies atoms typ name cabalRange = map doBundled $ convert' (canonical (Or (catMaybes (map convert alts)))) where -- Compute a list of alternative debian dependencies for -- satisfying a cabal dependency. The only caveat is that -- we may need to distribute any "and" dependencies implied -- by a version range over these "or" dependences. alts :: [(BinPkgName, VersionRange)] alts = case Map.lookup name (getL debianNameMap atoms) of -- If there are no splits for this package just return the single dependency for the package Nothing -> [(mkPkgName name typ, cabalRange')] -- If there are splits create a list of (debian package name, VersionRange) pairs Just splits' -> map (\ (n, r) -> (mkPkgName' n typ, r)) (packageRangesFromVersionSplits splits') convert :: (BinPkgName, VersionRange) -> Maybe (Rels Relation) convert (dname, range) = if isNoVersion range''' then Nothing else Just $ foldVersionRange' (Rel (D.Rel dname Nothing Nothing)) (\ v -> Rel (D.Rel dname (Just (D.EEQ (dv v))) Nothing)) (\ v -> Rel (D.Rel dname (Just (D.SGR (dv v))) Nothing)) (\ v -> Rel (D.Rel dname (Just (D.SLT (dv v))) Nothing)) (\ v -> Rel (D.Rel dname (Just (D.GRE (dv v))) Nothing)) (\ v -> Rel (D.Rel dname (Just (D.LTE (dv v))) Nothing)) (\ x y -> And [Rel (D.Rel dname (Just (D.GRE (dv x))) Nothing), Rel (D.Rel dname (Just (D.SLT (dv y))) Nothing)]) (\ x y -> Or [x, y]) (\ x y -> And [x, y]) id range''' where -- Choose the simpler of the two range''' = canon (simpler range' range'') -- Unrestrict the range for versions that we know don't exist for this debian package range'' = canon (unionVersionRanges range' (invertVersionRange range)) -- Restrict the range to the versions specified for this debian package range' = intersectVersionRanges cabalRange' range -- When we see a cabal equals dependency we need to turn it into -- a wildcard because the resulting debian version numbers have -- various suffixes added. cabalRange' = foldVersionRange' anyVersion withinVersion -- <- Here we are turning equals into wildcard laterVersion earlierVersion orLaterVersion orEarlierVersion (\ lb ub -> intersectVersionRanges (orLaterVersion lb) (earlierVersion ub)) unionVersionRanges intersectVersionRanges id cabalRange -- Convert a cabal version to a debian version, adding an epoch number if requested dv v = parseDebianVersion (maybe "" (\ n -> show n ++ ":") (Map.lookup name (getL epochMap atoms)) ++ showVersion v) simpler v1 v2 = minimumBy (compare `on` (length . asVersionIntervals)) [v1, v2] -- Simplify a VersionRange canon = fromVersionIntervals . toVersionIntervals -- If a package is bundled with the compiler we make the -- compiler a substitute for that package. If we were to -- specify the virtual package (e.g. libghc-base-dev) we would -- have to make sure not to specify a version number. doBundled :: [D.Relation] -> [D.Relation] doBundled rels | ghcBuiltIn (fromMaybe (error "dependencies") $ getL compiler atoms) name = rels ++ [D.Rel (compilerPackageName typ) Nothing Nothing] doBundled rels = rels compilerPackageName Documentation = D.BinPkgName "ghc-doc" compilerPackageName Profiling = D.BinPkgName "ghc-prof" compilerPackageName Development = D.BinPkgName "ghc" compilerPackageName _ = D.BinPkgName "ghc" -- whatevs data Rels a = And {unAnd :: [Rels a]} | Or {unOr :: [Rels a]} | Rel {unRel :: a} deriving Show convert' :: Rels a -> [[a]] convert' = map (map unRel . unOr) . unAnd . canonical -- | return and of ors of rel canonical :: Rels a -> Rels a canonical (Rel rel) = And [Or [Rel rel]] canonical (And rels) = And $ concatMap (unAnd . canonical) rels canonical (Or rels) = And . map Or $ sequence $ map (concat . map unOr . unAnd . canonical) $ rels debianName :: (PkgName name) => Atoms -> PackageType -> PackageIdentifier -> name debianName atoms typ pkgDesc = debianName' (Map.lookup (pkgName pkgDesc) (getL debianNameMap atoms)) typ pkgDesc -- | Function that applies the mapping from cabal names to debian -- names based on version numbers. If a version split happens at v, -- this will return the ltName if < v, and the geName if the relation -- is >= v. debianName' :: (PkgName name) => Maybe VersionSplits -> PackageType -> PackageIdentifier -> name debianName' msplits typ pkgDesc = case msplits of Nothing -> mkPkgName pname typ Just splits -> (\ s -> mkPkgName' s typ) $ doSplits splits version where -- def = mkPkgName pname typ pname@(PackageName _) = pkgName pkgDesc version = (Just (D.EEQ (parseDebianVersion (showVersion (pkgVersion pkgDesc))))) -- | Given a control file and a DebType, look for the binary deb with -- the corresponding suffix and return its name. debNameFromType :: Control' String -> DebType -> Maybe BinPkgName debNameFromType control debType = case debType of Dev -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-dev") debNames) Prof -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-prof") debNames) Doc -> fmap BinPkgName $ listToMaybe (filter (isSuffixOf "-doc") debNames) where debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control)))) -- | Build a debian package name from a cabal package name and a -- debian package type. Unfortunately, this does not enforce the -- correspondence between the PackageType value and the name type, so -- it can return nonsense like (SrcPkgName "libghc-debian-dev"). mkPkgName :: PkgName name => PackageName -> PackageType -> name mkPkgName pkg typ = mkPkgName' (debianBaseName pkg) typ mkPkgName' :: PkgName name => String -> PackageType -> name mkPkgName' base typ = pkgNameFromString $ case typ of Documentation -> "libghc-" ++ base ++ "-doc" Development -> "libghc-" ++ base ++ "-dev" Profiling -> "libghc-" ++ base ++ "-prof" Utilities -> "haskell-" ++ base ++ "-utils" Exec -> base Source' -> "haskell-" ++ base ++ "" Cabal -> base debianBaseName :: PackageName -> String debianBaseName (PackageName name) = map (fixChar . toLower) name where -- Underscore is prohibited in debian package names. fixChar :: Char -> Char fixChar '_' = '-' fixChar c = toLower c {- -- | Generate the head of the debian/rules file. cdbsRules :: PackageIdentifier -> Atoms -> Atoms cdbsRules pkgId deb = setL rulesHead (Just . unlines $ ["#!/usr/bin/make -f", "", "DEB_CABAL_PACKAGE = " <> name, "", "include /usr/share/cdbs/1/rules/debhelper.mk", "include /usr/share/cdbs/1/class/hlibrary.mk" ]) deb where -- The name is based on the cabal package, but it may need to be -- modified to avoid violating Debian rules - no underscores, no -- capital letters. name = pack (show (pretty (debianName deb Cabal pkgId :: BinPkgName))) -} getRulesHead :: Atoms -> Text getRulesHead atoms = fromMaybe computeRulesHead (getL rulesHead atoms) where computeRulesHead = unlines $ ["#!/usr/bin/make -f", ""] ++ maybe [] (\ x -> ["DEB_CABAL_PACKAGE = " <> x, ""]) (fmap name (getL packageDescription atoms)) ++ ["include /usr/share/cdbs/1/rules/debhelper.mk", "include /usr/share/cdbs/1/class/hlibrary.mk"] name pkgDesc = pack (show (pretty (debianName atoms Cabal (Cabal.package pkgDesc) :: BinPkgName))) filterMissing :: Atoms -> [[Relation]] -> [[Relation]] filterMissing atoms rels = filter (/= []) (List.map (filter (\ (D.Rel name _ _) -> not (Set.member name (getL missingDependencies atoms)))) rels) binaryPackageDeps :: BinPkgName -> Atoms -> [[Relation]] binaryPackageDeps b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL depends atoms)) binaryPackageConflicts :: BinPkgName -> Atoms -> [[Relation]] binaryPackageConflicts b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL conflicts atoms)) binaryPackageReplaces :: BinPkgName -> Atoms -> [[Relation]] binaryPackageReplaces b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL replaces atoms)) binaryPackageProvides :: BinPkgName -> Atoms -> [[Relation]] binaryPackageProvides b atoms = maybe [] (map (: []) . Set.toList) (Map.lookup b (getL provides atoms)) cabal-debian-3.9/src/Debian/Debianize/Goodies.hs0000644000175000017500000004314312236246354017565 0ustar dsfdsf-- | Things that seem like they could be clients of this library, but -- are instead included as part of the library. {-# LANGUAGE OverloadedStrings #-} module Debian.Debianize.Goodies ( tightDependencyFixup , doServer , doWebsite , doBackups , doExecutable , debianDescription , describe , watchAtom , oldClckwrksSiteFlags , oldClckwrksServerFlags , siteAtoms , serverAtoms , backupAtoms , execAtoms ) where import Data.Lens.Lazy (getL, modL) import Data.List as List (map, intersperse, intercalate) import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Set as Set (insert, union, singleton) import Data.Text as Text (Text, pack, unlines, intercalate) import Debian.Debianize.Atoms as Atoms () import Debian.Debianize.Atoms as Atoms (Atoms, packageDescription, rulesFragments, website, serverInfo, link, backups, executable, install, installTo, installCabalExecTo, file, installDir, logrotateStanza, postInst, installInit, installCabalExec, rulesFragments, packageDescription, executable, serverInfo, website, backups, depends) import Debian.Debianize.ControlFile as Debian (PackageType(..)) import Debian.Debianize.Types (InstallFile(..), Server(..), Site(..)) import Debian.Debianize.Utility (trim) import Debian.Orphans () import Debian.Policy (apacheLogDirectory, apacheErrorLog, apacheAccessLog, databaseDirectory, serverAppLog, serverAccessLog) import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel)) import Distribution.Package (PackageIdentifier(..), PackageName(PackageName)) import qualified Distribution.PackageDescription as Cabal import Distribution.Text (display) import Prelude hiding (writeFile, init, unlines, log, map) import System.FilePath (()) import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty)) showCommand :: String -> [String] -> String showCommand cmd args = unwords (map translate (cmd : args)) translate :: String -> String translate str = '"' : foldr escape "\"" str where escape '"' = showString "\\\"" escape c = showChar c -- | Create equals dependencies. For each pair (A, B), use dpkg-query -- to find out B's version number, version B. Then write a rule into -- P's .substvar that makes P require that that exact version of A, -- and another that makes P conflict with any older version of A. tightDependencyFixup :: [(BinPkgName, BinPkgName)] -> BinPkgName -> Atoms -> Atoms tightDependencyFixup [] _ deb = deb tightDependencyFixup pairs p deb = modL rulesFragments (Set.insert (Text.unlines $ ([ "binary-fixup/" <> name <> "::" , "\techo -n 'haskell:Depends=' >> debian/" <> name <> ".substvars" ] ++ intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map equals pairs) ++ [ "\techo '' >> debian/" <> name <> ".substvars" , "\techo -n 'haskell:Conflicts=' >> debian/" <> name <> ".substvars" ] ++ intersperse ("\techo -n ', ' >> debian/" <> name <> ".substvars") (List.map newer pairs) ++ [ "\techo '' >> debian/" <> name <> ".substvars" ]))) deb where equals (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (=$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars" newer (installed, dependent) = "\tdpkg-query -W -f='" <> display' dependent <> " (>>$${Version})' " <> display' installed <> " >> debian/" <> name <> ".substvars" name = display' p display' = pack . show . pretty -- | Add a debian binary package to the debianization containing a cabal executable file. doExecutable :: BinPkgName -> InstallFile -> Atoms -> Atoms doExecutable bin x deb = modL executable (Map.insertWith (\ a b -> error $ "doExecutable: " ++ show (a, b)) bin x) deb -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a server. doServer :: BinPkgName -> Server -> Atoms -> Atoms doServer bin x deb = modL serverInfo (Map.insertWith (\ a b -> error $ "doServer: " ++ show (a, b)) bin x) deb -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a web site. doWebsite :: BinPkgName -> Site -> Atoms -> Atoms doWebsite bin x deb = modL website (Map.insertWith (\ a b -> error $ "doWebsite: " ++ show (a, b)) bin x) deb -- | Add a debian binary package to the debianization containing a cabal executable file set up to be a backup script. doBackups :: BinPkgName -> String -> Atoms -> Atoms doBackups bin s deb = modL backups (Map.insertWith (error "backups") bin s) $ modL Atoms.depends (Map.insertWith union bin (singleton (Rel (BinPkgName "anacron") Nothing Nothing))) $ deb describe :: Atoms -> PackageType -> PackageIdentifier -> Text describe atoms typ ident = debianDescription (Cabal.synopsis pkgDesc) (Cabal.description pkgDesc) (Cabal.author pkgDesc) (Cabal.maintainer pkgDesc) (Cabal.pkgUrl pkgDesc) typ ident where pkgDesc = fromMaybe (error $ "describe " ++ show ident) $ getL packageDescription atoms debianDescription :: String -> String -> String -> String -> String -> PackageType -> PackageIdentifier -> Text debianDescription synopsis' description' author' maintainer' url typ pkgId = debianDescriptionBase synopsis' description' author' maintainer' url <> "\n" <> case typ of Profiling -> Text.intercalate "\n" [" .", " This package provides a library for the Haskell programming language, compiled", " for profiling. See http:///www.haskell.org/ for more information on Haskell."] Development -> Text.intercalate "\n" [" .", " This package provides a library for the Haskell programming language.", " See http:///www.haskell.org/ for more information on Haskell."] Documentation -> Text.intercalate "\n" [" .", " This package provides the documentation for a library for the Haskell", " programming language.", " See http:///www.haskell.org/ for more information on Haskell." ] Exec -> Text.intercalate "\n" [" .", " An executable built from the " <> pack (display (pkgName pkgId)) <> " package."] {- ServerPackage -> Text.intercalate "\n" [" .", " A server built from the " <> pack (display (pkgName pkgId)) <> " package."] -} Utilities -> Text.intercalate "\n" [" .", " Utility files associated with the " <> pack (display (pkgName pkgId)) <> " package."] x -> error $ "Unexpected library package name suffix: " ++ show x -- | The Cabal package has one synopsis and one description field -- for the entire package, while in a Debian package there is a -- description field (of which the first line is synopsis) in -- each binary package. So the cabal description forms the base -- of the debian description, each of which is amended. debianDescriptionBase :: String -> String -> String -> String -> String -> Text debianDescriptionBase synopsis' description' author' maintainer' url = (pack . unwords . words $ synopsis') <> case description' of "" -> "" text -> let text' = text ++ "\n" ++ list "" ("\n Author: " ++) author' ++ list "" ("\n Upstream-Maintainer: " ++) maintainer' ++ list "" ("\n Url: " ++) url in "\n " <> (pack . trim . List.intercalate "\n " . List.map addDot . lines $ text') where addDot line = if all (flip elem " \t") line then "." else line list :: b -> ([a] -> b) -> [a] -> b list d f l = case l of [] -> d; _ -> f l oldClckwrksSiteFlags :: Site -> [String] oldClckwrksSiteFlags x = [ -- According to the happstack-server documentation this needs a trailing slash. "--base-uri", "http://" ++ domain x ++ "/" , "--http-port", show port] oldClckwrksServerFlags :: Server -> [String] oldClckwrksServerFlags x = [ -- According to the happstack-server documentation this needs a trailing slash. "--base-uri", "http://" ++ hostname x ++ ":" ++ show (port x) ++ "/" , "--http-port", show port] watchAtom :: PackageName -> Text watchAtom (PackageName pkgname) = pack $ "version=3\nopts=\"downloadurlmangle=s|archive/([\\w\\d_-]+)/([\\d\\.]+)/|archive/$1/$2/$1-$2.tar.gz|,\\\nfilenamemangle=s|(.*)/$|" ++ pkgname ++ "-$1.tar.gz|\" \\\n http://hackage.haskell.org/package/" ++ pkgname ++ " \\\n ([\\d\\.]*\\d)/\n" siteAtoms :: BinPkgName -> Site -> Atoms -> Atoms siteAtoms b site = modL installDir (Map.insertWith Set.union b (singleton "/etc/apache2/sites-available")) . modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ domain site, "/etc/apache2/sites-enabled/" ++ domain site))) . modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" domain site, apacheConfig))) . modL installDir (Map.insertWith Set.union b (singleton (apacheLogDirectory b))) . modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $ [ pack (apacheAccessLog b) <> " {" , " weekly" , " rotate 5" , " compress" , " missingok" , "}"]))) . modL logrotateStanza (Map.insertWith Set.union b (singleton (Text.unlines $ [ pack (apacheErrorLog b) <> " {" , " weekly" , " rotate 5" , " compress" , " missingok" , "}" ]))) . serverAtoms b (server site) True where -- An apache site configuration file. This is installed via a line -- in debianFiles. apacheConfig = Text.unlines $ [ "" , " ServerAdmin " <> pack (serverAdmin site) , " ServerName www." <> pack (domain site) , " ServerAlias " <> pack (domain site) , "" , " ErrorLog " <> pack (apacheErrorLog b) , " CustomLog " <> pack (apacheAccessLog b) <> " combined" , "" , " ProxyRequests Off" , " AllowEncodedSlashes NoDecode" , "" , " " , " AddDefaultCharset off" , " Order deny,allow" , " #Allow from .example.com" , " Deny from all" , " #Allow from all" , " " , "" , " port' <> "/*>" , " AddDefaultCharset off" , " Order deny,allow" , " #Allow from .example.com" , " #Deny from all" , " Allow from all" , " " , "" , " SetEnv proxy-sendcl 1" , "" , " ProxyPass / http://127.0.0.1:" <> port' <> "/ nocanon" , " ProxyPassReverse / http://127.0.0.1:" <> port' <> "/" , "" ] port' = pack (show (port (server site))) serverAtoms :: BinPkgName -> Server -> Bool -> Atoms -> Atoms serverAtoms b server' isSite = modL postInst (insertWith (error "serverAtoms") b debianPostinst) . modL installInit (Map.insertWith (error "serverAtoms") b debianInit) . serverLogrotate' b . execAtoms b exec where exec = installFile server' debianInit = Text.unlines $ [ "#! /bin/sh -e" , "" , ". /lib/lsb/init-functions" , "test -f /etc/default/" <> pack (destName exec) <> " && . /etc/default/" <> pack (destName exec) , "" , "case \"$1\" in" , " start)" , " test -x /usr/bin/" <> pack (destName exec) <> " || exit 0" , " log_begin_msg \"Starting " <> pack (destName exec) <> "...\"" , " mkdir -p " <> pack (databaseDirectory b) , " " <> startCommand , " log_end_msg $?" , " ;;" , " stop)" , " log_begin_msg \"Stopping " <> pack (destName exec) <> "...\"" , " " <> stopCommand , " log_end_msg $?" , " ;;" , " *)" , " log_success_msg \"Usage: ${0} {start|stop}\"" , " exit 1" , "esac" , "" , "exit 0" ] startCommand = pack $ showCommand "start-stop-daemon" (startOptions ++ commonOptions ++ ["--"] ++ serverFlags server') stopCommand = pack $ showCommand "start-stop-daemon" (stopOptions ++ commonOptions) commonOptions = ["--pidfile", "/var/run/" ++ destName exec] startOptions = ["--start", "-b", "--make-pidfile", "-d", databaseDirectory b, "--exec", "/usr/bin" destName exec] stopOptions = ["--stop", "--oknodo"] ++ if retry server' /= "" then ["--retry=" ++ retry server' ] else [] debianPostinst = Text.unlines $ ([ "#!/bin/sh" , "" , "case \"$1\" in" , " configure)" ] ++ (if isSite then [ " # Apache won't start if this directory doesn't exist" , " mkdir -p " <> pack (apacheLogDirectory b) , " # Restart apache so it sees the new file in /etc/apache2/sites-enabled" , " /usr/sbin/a2enmod proxy" , " /usr/sbin/a2enmod proxy_http" , " service apache2 restart" ] else []) ++ [ -- This gets done by the #DEBHELPER# code below. {- " service " <> pack (show (pretty b)) <> " start", -} " ;;" , "esac" , "" , "#DEBHELPER#" , "" , "exit 0" ]) -- | A configuration file for the logrotate facility, installed via a line -- in debianFiles. serverLogrotate' :: BinPkgName -> Atoms -> Atoms serverLogrotate' b = modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAccessLog b) <> " {" , " weekly" , " rotate 5" , " compress" , " missingok" , "}" ]))) . modL logrotateStanza (insertWith Set.union b (singleton (Text.unlines $ [ pack (serverAppLog b) <> " {" , " weekly" , " rotate 5" , " compress" , " missingok" , "}" ]))) backupAtoms :: BinPkgName -> String -> Atoms -> Atoms backupAtoms b name = modL postInst (insertWith (error "backupAtoms") b (Text.unlines $ [ "#!/bin/sh" , "" , "case \"$1\" in" , " configure)" , " " <> pack ("/etc/cron.hourly" name) <> " --initialize" , " ;;" , "esac" ])) . execAtoms b (InstallFile { execName = name , destName = name , sourceDir = Nothing , destDir = Just "/etc/cron.hourly" }) execAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms execAtoms b ifile r = modL rulesFragments (Set.insert (pack ("build" show (pretty b) ++ ":: build-ghc-stamp"))) . fileAtoms b ifile $ r fileAtoms :: BinPkgName -> InstallFile -> Atoms -> Atoms fileAtoms b installFile' r = fileAtoms' b (sourceDir installFile') (execName installFile') (destDir installFile') (destName installFile') r fileAtoms' :: BinPkgName -> Maybe FilePath -> String -> Maybe FilePath -> String -> Atoms -> Atoms fileAtoms' b sourceDir' execName' destDir' destName' r = case (sourceDir', execName' == destName') of (Nothing, True) -> modL installCabalExec (insertWith Set.union b (singleton (execName', d))) r (Just s, True) -> modL install (insertWith Set.union b (singleton (s execName', d))) r (Nothing, False) -> modL installCabalExecTo (insertWith Set.union b (singleton (execName', (d destName')))) r (Just s, False) -> modL installTo (insertWith Set.union b (singleton (s execName', d destName'))) r where d = fromMaybe "usr/bin" destDir' cabal-debian-3.9/src/Debian/Debianize/Types.hs0000644000175000017500000000505412236246354017277 0ustar dsfdsfmodule Debian.Debianize.Types ( Top(..) , PackageInfo(..) , Site(..) , Server(..) , InstallFile(..) , DebType(..) , DebAction(..) ) where import Debian.Orphans () import Debian.Relation (BinPkgName) import Debian.Version (DebianVersion) import Distribution.Package (PackageName) import Prelude hiding (init, unlines, log) newtype Top = Top {unTop :: FilePath} data PackageInfo = PackageInfo { cabalName :: PackageName , devDeb :: Maybe (BinPkgName, DebianVersion) , profDeb :: Maybe (BinPkgName, DebianVersion) , docDeb :: Maybe (BinPkgName, DebianVersion) } deriving (Eq, Ord, Show) -- | Information about the web site we are packaging. data Site = Site { domain :: String -- ^ The domain name assigned to the server. -- An apache configuration will be generated to -- redirect requests from this domain to hostname:port , serverAdmin :: String -- ^ Apache ServerAdmin parameter , server :: Server -- ^ The hint to install the server job } deriving (Read, Show, Eq, Ord) -- | Information about the server we are packaging. data Server = Server { hostname :: String -- ^ Host on which the server will run , port :: Int -- ^ Port on which the server will run. -- Obviously, this must assign each and -- every server package to a different -- port. , headerMessage :: String -- ^ A comment that will be inserted to -- explain how the file was generated , retry :: String -- ^ start-stop-daemon --retry argument , serverFlags :: [String] -- ^ Extra flags to pass to the server via the init script , installFile :: InstallFile -- ^ The hint to install the server executable } deriving (Read, Show, Eq, Ord) data InstallFile = InstallFile { execName :: String -- ^ The name of the executable file , sourceDir :: Maybe FilePath -- ^ where to find it, default is dist/build// , destDir :: Maybe FilePath -- ^ where to put it, default is usr/bin/ , destName :: String -- ^ name to give installed executable } deriving (Read, Show, Eq, Ord) data DebAction = Usage | Debianize | SubstVar DebType deriving (Read, Show, Eq, Ord) -- | A redundant data type, too lazy to expunge. data DebType = Dev | Prof | Doc deriving (Eq, Ord, Read, Show) cabal-debian-3.9/src/Debian/Debianize/Atoms.hs0000644000175000017500000016010012236246354017250 0ustar dsfdsf{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TupleSections #-} module Debian.Debianize.Atoms ( Atoms -- * Modes of operation , verbosity , dryRun , validate , debAction , flags , warning -- * Cabal info , compilerVersion , packageDescription , buildDir , dataDir , compiler , extraLibMap , execMap , cabalFlagAssignments -- * Global debian info , debianNameMap , epochMap -- * High level information about the debianization , description , executable , serverInfo , website , backups , apacheSite , missingDependencies , utilsPackageNames , sourcePackageName , revision , debVersion , maintainer , packageInfo , omitLTDeps , noProfilingLibrary , noDocumentationLibrary , copyright , sourceArchitecture , binaryArchitectures , sourcePriority , binaryPriorities , sourceSection , binarySections , buildDeps , buildDepsIndep , depends , conflicts , replaces , provides , extraDevDeps -- * Debianization files and file fragments , rulesHead , rulesFragments , postInst , postRm , preInst , preRm , compat , sourceFormat , watch , changelog , comments , control , standards , logrotateStanza , link , install , installTo , installData , file , installCabalExec , installCabalExecTo , installDir , installInit , intermediateFiles ) where import Data.Char (toLower) import Data.Generics (Data, Typeable) import Data.Lens.Lazy (Lens, lens, getL, modL) import Data.Map as Map (Map, fold, foldWithKey, insertWith, empty, insert) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) import Data.Set as Set (Set, maxView, empty, union, singleton, fold, insert) import Data.Text (Text) import Data.Version (Version, showVersion) import Debian.Changes (ChangeLog) import Debian.Debianize.ControlFile (SourceDebDescription(standardsVersion), newSourceDebDescription) import Debian.Debianize.Types (PackageInfo(..), Site(..), Server(..), InstallFile(..), DebAction(..)) import Debian.Debianize.Types.VersionSplits (VersionSplits) import Debian.Orphans () import Debian.Policy (PackageArchitectures, SourceFormat, PackagePriority, Section, StandardsVersion) import Debian.Relation (SrcPkgName, BinPkgName, Relations, Relation(..)) import Debian.Version (DebianVersion) import Distribution.License (License) import Distribution.Package (PackageName(PackageName), PackageIdentifier(..)) import Distribution.PackageDescription as Cabal (PackageDescription(package), FlagName, PackageDescription) import Distribution.Simple.Compiler (Compiler) import Prelude hiding (init, unlines, log) import System.FilePath (()) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr) -- All the internals of this module is a steaming pile of poo, except -- for the stuff that is exported. data DebAtomKey = Source | Binary BinPkgName deriving (Eq, Ord, Data, Typeable, Show) -- | The smallest pieces of debhelper information. Some of these are -- converted directly into files in the debian directory, others -- become fragments of those files, and others are first converted -- into different DebAtom values as new information becomes available. data DebAtom = NoDocumentationLibrary -- ^ Do not produce a libghc-foo-doc package. | NoProfilingLibrary -- ^ Do not produce a libghc-foo-prof package. | CompilerVersion Version -- ^ Specify the version number of the GHC compiler in the build -- environment. The default is to assume that version is the same -- as the one in the environment where cabal-debian is running. -- This is used to look up hard coded lists of packages bundled -- with the compiler and their version numbers. (This could -- certainly be done in a more beautiful way.) | DHPackageDescription PackageDescription -- ^ The cabal package description record | DHCompiler Compiler -- ^ The Compiler value returned with the Cabal -- PackageDescription, then used to determine what libraries -- (i.e. dependencies) are provided by the compiler. | BuildDir FilePath -- ^ The build directory used by cabal, typically dist/build when -- building manually or dist-ghc/build when building using GHC and -- haskell-devscripts. This value is used to locate files -- produced by cabal so we can move them into the deb. Note that -- the --builddir option of runhaskell Setup appends the "/build" -- to the value it receives, so, yes, try not to get confused. | DataDir FilePath -- ^ the pathname of the package's data directory, generally the -- value of the dataDirectory field in the PackageDescription. | DebSourceFormat SourceFormat -- ^ Write debian/source/format | DebWatch Text -- ^ Write debian/watch | DHIntermediate FilePath Text -- ^ Put this text into a file with the given name in the debianization. | DebRulesHead Text -- ^ The header of the debian/rules file. The remainder is assembled -- from DebRulesFragment values in the atom list. | DebRulesFragment Text -- ^ A Fragment of debian/rules | Warning Text -- ^ A warning to be reported later | UtilsPackageNames (Set BinPkgName) -- ^ Names of the packages that will get left-over data files and executables | DebChangeLog ChangeLog -- ^ The changelog, first entry contains the source package name and version | DebLogComments [[Text]] -- ^ Each element is a comment to be added to the changelog, where the -- element's text elements are the lines of the comment. | DHMaintainer NameAddr -- ^ Value for the maintainer field in the control file. Note that -- the cabal maintainer field can have multiple addresses, but debian -- only one. If this is not explicitly set, it is obtained from the -- cabal file, and if it is not there then from the environment. As a -- last resort, there is a hard coded string in here somewhere. | DHCabalFlagAssignments (Set (FlagName, Bool)) -- ^ Flags to pass to Cabal function finalizePackageDescription, this -- can be used to control the flags in the cabal file. | DHFlags Flags -- ^ Information regarding mode of operation - verbosity, dry-run, usage, etc | DebRevision String -- ^ Specify the revision string to use when converting the cabal -- version to debian. | OmitLTDeps -- ^ If present, don't generate the << dependency when we see a cabal -- equals dependency. (The implementation of this was somehow lost.) | DebVersion DebianVersion -- ^ Specify the exact debian version of the resulting package, -- including epoch. One use case is to work around the the -- "buildN" versions that are often uploaded to the debian and -- ubuntu repositories. Say the latest cabal version of -- transformers is 0.3.0.0, but the debian repository contains -- version 0.3.0.0-1build3, we need to specify -- debVersion="0.3.0.0-1build3" or the version we produce will -- look older than the one already available upstream. | DebianNameMap (Map PackageName VersionSplits) -- ^ Mapping from cabal package name and version to debian source -- package name. This allows different ranges of cabal versions to -- map to different debian source package names. | SourcePackageName SrcPkgName -- ^ Name to give to the debian source package. If not supplied -- the name is constructed from the cabal package name. Note that -- DebianNameMap could encode this information if we already knew -- the cabal package name, but we can't assume that. | BuildDep Relations -- ^ Add build dependencies | BuildDepIndep Relations -- ^ Add arch independent build dependencies | MissingDependency BinPkgName -- ^ Lets cabal-debian know that a package it might expect to exist -- actually does not, so omit all uses in resulting debianization. | ExtraLibMapping String Relations -- ^ Map a cabal Extra-Library name to a debian binary package name, -- e.g. @ExtraLibMapping extraLibMap "cryptopp" "libcrypto-dev"@ adds a -- build dependency *and* a regular dependency on @libcrypto-dev@ to -- any package that has @cryptopp@ in its cabal Extra-Library list. | ExecMapping String Relations -- ^ Map a cabal Build-Tool name to a debian binary package name, -- e.g. @ExecMapping "trhsx" "haskell-hsx-utils"@ adds a build -- dependency on @haskell-hsx-utils@ to any package that has @trhsx@ in its -- cabal build-tool list. | EpochMapping PackageName Int -- ^ Specify epoch numbers for the debian package generated from a -- cabal package. Example: @EpochMapping (PackageName "HTTP") 1@. | DebPackageInfo PackageInfo -- ^ Supply some info about a cabal package. | DebCompat Int -- ^ The debhelper compatibility level, from debian/compat. | DebCopyright (Either License Text) -- ^ Copyright information, either as a Cabal License value or -- the full text. | DebControl SourceDebDescription -- ^ The parsed contents of the control file -- From here down are atoms to be associated with a Debian binary -- package. This could be done with more type safety, separate -- maps for the Source atoms and the Binary atoms. | DHApacheSite String FilePath Text -- ^ Have Apache configure a site using PACKAGE, DOMAIN, LOGDIR, and APACHECONFIGFILE | DHLogrotateStanza Text -- ^ Add a stanza of a logrotate file to the binary package | DHLink FilePath FilePath -- ^ Create a symbolic link in the binary package | DHPostInst Text -- ^ Script to run after install, should contain #DEBHELPER# line before exit 0 | DHPostRm Text -- ^ Script to run after remove, should contain #DEBHELPER# line before exit 0 | DHPreInst Text -- ^ Script to run before install, should contain #DEBHELPER# line before exit 0 | DHPreRm Text -- ^ Script to run before remove, should contain #DEBHELPER# line before exit 0 | DHArch PackageArchitectures -- ^ Set the Architecture field of source or binary | DHPriority PackagePriority -- ^ Set the Priority field of source or binary | DHSection Section -- ^ Set the Section field of source or binary | DHDescription Text -- ^ Set the description of source or binary | DHInstall FilePath FilePath -- ^ Install a build file into the binary package | DHInstallTo FilePath FilePath -- ^ Install a build file into the binary package at an exact location | DHInstallData FilePath FilePath -- ^ DHInstallTo somewhere relative to DataDir (see above) | DHFile FilePath Text -- ^ Create a file with the given text at the given path | DHInstallCabalExec String FilePath -- ^ Install a cabal executable into the binary package | DHInstallCabalExecTo String FilePath -- ^ Install a cabal executable into the binary package at an exact location | DHInstallDir FilePath -- ^ Create a directory in the binary package | DHInstallInit Text -- ^ Add an init.d file to the binary package | DHExecutable InstallFile -- ^ Create a binary package to hold a cabal executable | DHServer Server -- ^ Like DHExecutable, but configure the executable as a server process | DHWebsite Site -- ^ Like DHServer, but configure the server as a web server | DHBackups String -- ^ Configure the executable to do incremental backups | Depends Relation -- ^ Says that the debian package should have this relation in Depends | Conflicts Relation -- ^ Says that the debian package should have this relation in Conflicts | Provides Relation -- ^ Says that the debian package should have this relation in Provides | Replaces Relation -- ^ Says that the debian package should have this relation in Replaces | DevDepends Relation -- ^ Limited version of Depends, put a dependency on the dev library package. The only -- reason to use this is because we don't yet know the name of the dev library package. deriving (Eq, Ord, Show, Typeable) -- | This record supplies information about the task we want done - -- debianization, validataion, help message, etc. data Flags = Flags { ------------------------- -- Modes of Operation --- ------------------------- verbosity_ :: Int -- ^ Run with progress messages at the given level of verboseness. , dryRun_ :: Bool -- ^ Don't write any files or create any directories, just explain -- what would have been done. , validate_ :: Bool -- ^ Fail if the debianization already present doesn't match the -- one we are going to generate closely enough that it is safe to -- debianize during the run of dpkg-buildpackage, when Setup -- configure is run. Specifically, the version number in the top -- changelog entry must match, and the sets of package names in -- the control file must match. , debAction_ :: DebAction -- ^ What to do - Usage, Debianize or Substvar } deriving (Eq, Ord, Show) -- | Bits and pieces of information about the mapping from cabal package -- names and versions to debian package names and versions. In essence, -- an 'Atoms' value represents a package's debianization. The lenses in -- this module are used to get and set the values hidden in this Atoms -- value. Many of the values should be left alone to be set when the -- debianization is finalized. newtype Atoms = Atoms (Map DebAtomKey (Set DebAtom)) deriving (Eq, Show) instance Monoid Atoms where -- We need mempty to actually be an empty map because we test for -- this in the expandAtoms recursion. mempty = Atoms mempty -- defaultAtoms mappend a b = foldAtoms insertAtom a b -- Lenses to access values in the Atoms type. This is an old -- design which I plan to make private and turn into something -- nicer, so these will remain ugly and repetitive for now. -- | Set how much progress messages get generated. verbosity :: Lens Atoms Int verbosity = lens (\ a -> verbosity_ (getL flags a)) (\ b a -> modL flags (\ x -> x {verbosity_ = b}) a) -- | Don't write anything, just output a description of what would have happened dryRun :: Lens Atoms Bool dryRun = lens (\ a -> dryRun_ (getL flags a)) (\ b a -> modL flags (\ x -> x {dryRun_ = b}) a) -- | Make sure the version number and package names of the supplied -- and generated debianizations match. validate :: Lens Atoms Bool validate = lens (\ a -> validate_ (getL flags a)) (\ b a -> modL flags (\ x -> x {validate_ = b}) a) -- | Debianize, SubstVars, or Usage. I'm no longer sure what SubstVars does, but someone -- may still be using it. debAction :: Lens Atoms DebAction debAction = lens (\ a -> debAction_ (getL flags a)) (\ b a -> modL flags (\ x -> x {debAction_ = b}) a) -- | Obsolete record containing verbosity, dryRun, validate, and debAction. flags :: Lens Atoms Flags flags = lens g s where g atoms = fromMaybe defaultFlags $ foldAtoms from Nothing atoms where from Source (DHFlags x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x') from Source (DHFlags x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DHFlags) x)) atoms where f Source (DHFlags y) = Just y f _ _ = Nothing -- | Unused warning :: Lens Atoms (Set Text) warning = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (Warning t) x = Set.insert t x from _ _ x = x s x atoms = Set.fold (\ text atoms' -> insertAtom Source (Warning text) atoms') (deleteAtoms p atoms) x where p Source (Warning _) = True p _ _ = False -- | Set the compiler version, this is used when loading the cabal file to compilerVersion :: Lens Atoms (Maybe Version) compilerVersion = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (CompilerVersion x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (CompilerVersion x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . CompilerVersion) x)) atoms where f Source (CompilerVersion y) = Just y f _ _ = Nothing -- | The information loaded from the cabal file. packageDescription :: Lens Atoms (Maybe PackageDescription) packageDescription = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHPackageDescription x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DHPackageDescription x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPackageDescription) x)) atoms where f Source (DHPackageDescription y) = Just y f _ _ = Nothing -- | The build directory. This can be set by an argument to the @Setup@ script. -- When @Setup@ is run manually it is just @dist@, when it is run by -- @dpkg-buildpackage@ the compiler name is appended, so it is typically -- @dist-ghc@. Cabal-debian needs the correct value of buildDir to find -- the build results. buildDir :: Lens Atoms (Maybe FilePath) buildDir = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (BuildDir x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (BuildDir x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . BuildDir) x)) atoms where f Source (BuildDir y) = Just y f _ _ = Nothing -- | The data directory for the package, generated from the packageDescription dataDir :: Lens Atoms (Maybe FilePath) dataDir = lens g s where g atoms = fmap (\ p -> let PackageName pkgname = pkgName . package $ p in "usr/share" map toLower pkgname) (getL packageDescription atoms) s _ _ = error "setL dataDir" -- | The Compiler value returned when the cabal file was loaded. compiler :: Lens Atoms (Maybe Compiler) compiler = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHCompiler x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (DHCompiler x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHCompiler) x)) atoms where f Source (DHCompiler y) = Just y f _ _ = Nothing -- | Map from cabal Extra-Lib names to debian binary package names. extraLibMap :: Lens Atoms (Map String (Set Relations)) extraLibMap = lens g s where g atoms = foldAtoms from Map.empty atoms where from Source (ExtraLibMapping cabal debian) x = Map.insertWith union cabal (singleton debian) x from _ _ x = x s x atoms = Map.foldWithKey (\ cabal debian atoms' -> Set.fold (\ debian' atoms'' -> insertAtom Source (ExtraLibMapping cabal debian') atoms'') atoms' debian) (deleteAtoms p atoms) x where p Source (ExtraLibMapping _ _) = True p _ _ = False -- | Map from cabal Build-Tool names to debian binary package names. execMap :: Lens Atoms (Map String Relations) execMap = lens g s where g :: Atoms -> Map String Relations g atoms = foldAtoms from Map.empty atoms where from :: DebAtomKey -> DebAtom -> Map String Relations -> Map String Relations from Source (ExecMapping cabal debian) x = Map.insertWith (error "Conflict in execMap") cabal debian x from _ _ x = x s :: Map String Relations -> Atoms -> Atoms s x atoms = Map.foldWithKey (\ cabal debian atoms' -> insertAtom Source (ExecMapping cabal debian) atoms') (deleteAtoms p atoms) x where p Source (ExecMapping _ _) = True p _ _ = False -- | Cabal flag assignments to use when loading the cabal file. cabalFlagAssignments :: Lens Atoms (Set (FlagName, Bool)) cabalFlagAssignments = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (DHCabalFlagAssignments pairs) x = union pairs x from _ _ x = x s x atoms = insertAtom Source (DHCabalFlagAssignments x) (deleteAtoms p atoms) where p Source (DHCabalFlagAssignments _) = True p _ _ = False -- | Map from cabal version number ranges to debian package names. This is a -- result of the fact that only one version of a debian package can be -- installed at a given time, while multiple versions of a cabal packages can. debianNameMap :: Lens Atoms (Map PackageName VersionSplits) debianNameMap = lens g s where g atoms = foldAtoms from mempty atoms where from Source (DebianNameMap mp) _ = mp from _ _ mp = mp s x atoms = insertAtom Source (DebianNameMap x) (deleteAtoms p atoms) where p Source (DebianNameMap _) = True p _ _ = False -- | Map of Debian epoch numbers assigned to cabal packages. epochMap :: Lens Atoms (Map PackageName Int) epochMap = lens g s where g atoms = foldAtoms from Map.empty atoms where from Source (EpochMapping name epoch) x = Map.insertWith (error "Conflicting Epochs") name epoch x from _ _ x = x s x atoms = Map.foldWithKey (\ name epoch atoms' -> insertAtom Source (EpochMapping name epoch) atoms') (deleteAtoms p atoms) x where p Source (EpochMapping _ _) = True p _ _ = False -- | Map of binary deb descriptions. description :: Lens Atoms (Map BinPkgName Text) description = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHDescription d) x = Map.insertWith (error "description") b d x from _ _ x = x s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHDescription y) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHDescription _) = True p _ _ = False -- | Create a package to hold a cabal executable executable :: Lens Atoms (Map BinPkgName InstallFile) executable = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHExecutable f) x = Map.insertWith (\ k a -> error $ "executable: " ++ show (k, a)) b f x from _ _ x = x s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHExecutable y) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHExecutable _) = True p _ _ = False -- | Create a package for an operating service using the given executable serverInfo :: Lens Atoms (Map BinPkgName Server) serverInfo = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHServer s') x = Map.insertWith (error "server") b s' x from _ _ x = x s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHServer y) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHServer _) = True p _ _ = False -- | Create a package for a website using the given executable as the server website :: Lens Atoms (Map BinPkgName Site) website = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHWebsite s') x = Map.insertWith (error "website") b s' x from _ _ x = x s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHWebsite y) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHWebsite _) = True p _ _ = False -- | Generate a backups package using the given cabal executable backups :: Lens Atoms (Map BinPkgName String) backups = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHBackups s') x = Map.insertWith (error "backups") b s' x from _ _ x = x s x atoms = Map.foldWithKey (\ b y atoms'-> insertAtom (Binary b) (DHBackups y) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHBackups _) = True p _ _ = False -- | Create an apache configuration file with the given -- (domain, logdir, filetext). This is called when expanding -- the result of the website lens above. apacheSite :: Lens Atoms (Map BinPkgName (String, FilePath, Text)) apacheSite = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHApacheSite dom log text) x = Map.insertWith (error "backups") b (dom, log, text) x from _ _ x = x s x atoms = Map.foldWithKey (\ b (dom, log, text) atoms' -> insertAtom (Binary b) (DHApacheSite dom log text) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHApacheSite _ _ _) = True p _ _ = False -- * Lower level hints about the debianization -- | List if packages that should be omitted from any -- dependency list - e.g. a profiling package missing due -- to use of noProfilingPackage lens elsewhere. missingDependencies :: Lens Atoms (Set BinPkgName) missingDependencies = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (MissingDependency b) x = Set.insert b x from _ _ x = x s x atoms = Set.fold (\ b atoms' -> insertAtom Source (MissingDependency b) atoms') (deleteAtoms p atoms) x where p Source (MissingDependency _) = True p _ _ = False -- | Override the package name used to hold left over data files and executables. -- Usually only one package is specified, but if more then one are they will each -- receive the same list of files. utilsPackageNames :: Lens Atoms (Maybe (Set BinPkgName)) utilsPackageNames = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (UtilsPackageNames xs') (Just xs) | xs /= xs' = error $ "Conflicting compat values:" ++ show (xs, xs') from Source (UtilsPackageNames xs) _ = Just xs from _ _ xs = xs s xs atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . UtilsPackageNames) xs)) atoms where f Source (UtilsPackageNames ys) = Just ys f _ _ = Nothing -- | Override the debian source package name constructed from the cabal name sourcePackageName :: Lens Atoms (Maybe SrcPkgName) sourcePackageName = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (SourcePackageName x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (SourcePackageName x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . SourcePackageName) x)) atoms where f Source (SourcePackageName y) = Just y f _ _ = Nothing -- | Revision string used in constructing the debian verison number from the cabal version revision :: Lens Atoms (Maybe String) revision = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebRevision x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DebRevision x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRevision) x)) atoms where f Source (DebRevision y) = Just y f _ _ = Nothing -- | Exact debian version number, overrides the version generated from the cabal version debVersion :: Lens Atoms (Maybe DebianVersion) debVersion = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebVersion x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DebVersion x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebVersion) x)) atoms where f Source (DebVersion y) = Just y f _ _ = Nothing -- | Maintainer field. Overrides any value found in the cabal file, or -- in the DEBIANMAINTAINER environment variable. maintainer :: Lens Atoms (Maybe NameAddr) maintainer = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHMaintainer x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DHMaintainer x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHMaintainer) x)) atoms where f Source (DHMaintainer y) = Just y f _ _ = Nothing -- | No longer sure what the purpose of this lens is. packageInfo :: Lens Atoms (Map PackageName PackageInfo) packageInfo = lens g s where g atoms = foldAtoms from Map.empty atoms where from Source (DebPackageInfo i) x = Map.insert (cabalName i) i x from _ _ x = x s x atoms = Map.fold (\ i atoms' -> insertAtom Source (DebPackageInfo i) atoms') (deleteAtoms p atoms) x where p Source (DebPackageInfo _) = True p _ _ = False -- | Set this to filter any less-than dependencies out of the generated debian -- dependencies. (Not sure if this is implemented.) omitLTDeps :: Lens Atoms Bool omitLTDeps = lens g s where g atoms = foldAtoms from False atoms where from Source OmitLTDeps _ = True from _ _ x = x s x atoms = (if x then insertAtom Source OmitLTDeps else id) (deleteAtoms p atoms) where p Source OmitLTDeps = True p _ _ = False -- | Set this to omit the prof library deb. noProfilingLibrary :: Lens Atoms Bool noProfilingLibrary = lens g s where g atoms = foldAtoms from False atoms where from Source NoProfilingLibrary _ = True from _ _ x = x s x atoms = (if x then insertAtom Source NoProfilingLibrary else id) (deleteAtoms p atoms) where p Source NoProfilingLibrary = True p _ _ = False -- | Set this to omit the doc library deb. noDocumentationLibrary :: Lens Atoms Bool noDocumentationLibrary = lens g s where g atoms = foldAtoms from False atoms where from Source NoDocumentationLibrary _ = True from _ _ x = x s x atoms = (if x then insertAtom Source NoDocumentationLibrary else id) (deleteAtoms p atoms) where p Source NoDocumentationLibrary = True p _ _ = False -- | The copyright information copyright :: Lens Atoms (Maybe (Either License Text)) copyright = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebCopyright x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DebCopyright x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCopyright) x)) atoms where f Source (DebCopyright y) = Just y f _ _ = Nothing -- | The source package architecture - @Any@, @All@, or some list of specific architectures. sourceArchitecture :: Lens Atoms (Maybe PackageArchitectures) sourceArchitecture = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHArch x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DHArch x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHArch) x)) atoms where f Source (DHArch y) = Just y f _ _ = Nothing -- | Map of the binary package architectures binaryArchitectures :: Lens Atoms (Map BinPkgName PackageArchitectures) binaryArchitectures = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHArch x) m = Map.insert b x m from _ _ m = m s x atoms = Map.foldWithKey (\ b a atoms' -> insertAtom (Binary b) (DHArch a) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHArch _) = True p _ _ = False -- | The source package priority sourcePriority :: Lens Atoms (Maybe PackagePriority) sourcePriority = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHPriority x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DHPriority x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHPriority) x)) atoms where f Source (DHPriority y) = Just y f _ _ = Nothing -- | Map of the binary package priorities binaryPriorities :: Lens Atoms (Map BinPkgName PackagePriority) binaryPriorities = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHPriority p) x = Map.insertWith (error "priorities") b p x from _ _ x = x s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHPriority p') atoms') (deleteAtoms p atoms) x where p (Binary _) (DHPriority _) = True p _ _ = False -- | The source package's section assignment sourceSection :: Lens Atoms (Maybe Section) sourceSection = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DHSection x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DHSection x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DHSection) x)) atoms where f Source (DHSection y) = Just y f _ _ = Nothing -- | Map of the binary deb section assignments binarySections :: Lens Atoms (Map BinPkgName Section) binarySections = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHSection p) x = Map.insertWith (error "sections") b p x from _ _ x = x s x atoms = Map.foldWithKey (\ b p' atoms'-> insertAtom (Binary b) (DHSection p') atoms') (deleteAtoms p atoms) x where p (Binary _) (DHSection _) = True p _ _ = False -- * Debian dependency info -- | Build dependencies. FIXME: This should be a Set (Set Relation) -- so we can build or relations, right now we just assume that each -- Relation is a singleton set. buildDeps :: Lens Atoms (Set Relations) buildDeps = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (BuildDep r) x = Set.insert r x from _ _ x = x s x atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDep d) atoms') (deleteAtoms p atoms) x where p Source (BuildDep _) = True p _ _ = False -- | Architecture independent buildDepsIndep :: Lens Atoms (Set Relations) buildDepsIndep = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (BuildDepIndep r) x = Set.insert r x from _ _ x = x s r atoms = Set.fold (\ d atoms' -> insertAtom Source (BuildDepIndep d) atoms') (deleteAtoms p atoms) r where p Source (BuildDepIndep _) = True p _ _ = False -- | Map of extra install dependencies for the package's binary debs. -- This should be [[Relation]] for full generality, or Set (Set Relation) depends :: Lens Atoms (Map BinPkgName (Set Relation)) depends = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (Depends rel) x = Map.insertWith union b (singleton rel) x from _ _ x = x s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Depends rel) atoms'') atoms' rels) (deleteAtoms p atoms) x where p (Binary _) (Depends _) = True p _ _ = False -- | Map of extra install conflicts for the package's binary debs. -- We should support all the other dependency fields - provides, replaces, etc. conflicts :: Lens Atoms (Map BinPkgName (Set Relation)) conflicts = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (Conflicts rel) x = Map.insertWith union b (singleton rel) x from _ _ x = x s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Conflicts rel) atoms'') atoms' rels) (deleteAtoms p atoms) x where p (Binary _) (Conflicts _) = True p _ _ = False -- | Map of extra install replaces for the package's binary debs. -- We should support all the other dependency fields - provides, replaces, etc. replaces :: Lens Atoms (Map BinPkgName (Set Relation)) replaces = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (Replaces rel) x = Map.insertWith union b (singleton rel) x from _ _ x = x s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Replaces rel) atoms'') atoms' rels) (deleteAtoms p atoms) x where p (Binary _) (Replaces _) = True p _ _ = False -- | Map of extra install provides for the package's binary debs. -- We should support all the other dependency fields - provides, replaces, etc. provides :: Lens Atoms (Map BinPkgName (Set Relation)) provides = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (Provides rel) x = Map.insertWith union b (singleton rel) x from _ _ x = x s x atoms = Map.foldWithKey (\ b rels atoms' -> Set.fold (\ rel atoms'' -> insertAtom (Binary b) (Provides rel) atoms'') atoms' rels) (deleteAtoms p atoms) x where p (Binary _) (Provides _) = True p _ _ = False -- | Extra install dependencies for the devel library. Redundant -- with depends, but kept for backwards compatibility. Also, I -- think maybe this is or was needed because it can be set before -- the exact name of the library package is known. extraDevDeps :: Lens Atoms (Set Relation) extraDevDeps = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (DevDepends b) x = Set.insert b x from _ _ x = x s x atoms = Set.fold (\ d atoms' -> insertAtom Source (DevDepends d) atoms') (deleteAtoms p atoms) x where p Source (DevDepends _) = True p _ _ = False -- | The beginning of the rules file rulesHead :: Lens Atoms (Maybe Text) rulesHead = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebRulesHead x') (Just x) | x /= x' = error $ "Conflicting rulesHead values:" ++ show (x, x') from Source (DebRulesHead x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebRulesHead) x)) atoms where f Source (DebRulesHead y) = Just y f _ _ = Nothing -- | Additional fragments of the rules file rulesFragments :: Lens Atoms (Set Text) rulesFragments = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (DebRulesFragment t) x = Set.insert t x from _ _ x = x s x atoms = Set.fold (\ text atoms' -> insertAtom Source (DebRulesFragment text) atoms') (deleteAtoms p atoms) x where p Source (DebRulesFragment _) = True p _ _ = False -- | Map of @debian/postinst@ scripts postInst :: Lens Atoms (Map BinPkgName Text) postInst = lens g s where g atoms = foldAtoms from mempty atoms where from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text from (Binary b) (DHPostInst t) x = Map.insertWith (error "Conflicting postInsts") b t x from _ _ x = x s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostInst t) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHPostInst _) = True p _ _ = False -- | Map of @debian/postrm@ scripts postRm :: Lens Atoms (Map BinPkgName Text) postRm = lens g s where g atoms = foldAtoms from mempty atoms where from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text from (Binary b) (DHPostRm t) m = Map.insertWith (error "Conflicting postRms") b t m from _ _ x = x s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPostRm t) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHPostRm _) = True p _ _ = False -- | Map of @debian/preinst@ scripts preInst :: Lens Atoms (Map BinPkgName Text) preInst = lens g s where g atoms = foldAtoms from mempty atoms where from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text from (Binary b) (DHPreInst t) m = Map.insertWith (error "Conflicting preInsts") b t m from _ _ x = x s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreInst t) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHPreInst _) = True p _ _ = False -- | Map of @debian/prerm@ scripts preRm :: Lens Atoms (Map BinPkgName Text) preRm = lens g s where g atoms = foldAtoms from mempty atoms where from :: DebAtomKey -> DebAtom -> Map BinPkgName Text -> Map BinPkgName Text from (Binary b) (DHPreRm t) m = Map.insertWith (error "Conflicting preRms") b t m from _ _ x = x s x atoms = Map.foldWithKey (\ b t atoms' -> insertAtom (Binary b) (DHPreRm t) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHPreRm _) = True p _ _ = False -- | The @debian/compat@ file, contains the minimum compatible version of the @debhelper@ package compat :: Lens Atoms (Maybe Int) compat = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebCompat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (DebCompat x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebCompat) x)) atoms where f Source (DebCompat y) = Just y f _ _ = Nothing -- | The @debian/source/format@ file. sourceFormat :: Lens Atoms (Maybe SourceFormat) sourceFormat = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebSourceFormat x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (DebSourceFormat x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebSourceFormat) x)) atoms where f Source (DebSourceFormat y) = Just y f _ _ = Nothing -- | the @debian/watch@ file watch :: Lens Atoms (Maybe Text) watch = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebWatch x') (Just x) | x /= x' = error $ "Conflicting watch values:" ++ show (x, x') from Source (DebWatch x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebWatch) x)) atoms where f Source (DebWatch y) = Just y f _ _ = Nothing -- | the @debian/changelog@ file changelog :: Lens Atoms (Maybe ChangeLog) changelog = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebChangeLog x') (Just x) | x /= x' = error $ "Conflicting compat values:" ++ show (x, x') from Source (DebChangeLog x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebChangeLog) x)) atoms where f Source (DebChangeLog y) = Just y f _ _ = Nothing -- | Comment entries for the latest changelog entry (DebLogComments [[Text]]) comments :: Lens Atoms (Maybe [[Text]]) comments = lens g s where g atoms = foldAtoms from Nothing atoms where from Source (DebLogComments xss') (Just xss) | xss == xss' = error $ "Conflicting log comments: " ++ show (xss, xss') from Source (DebLogComments xss) _ = Just xss from _ _ x = x s x atoms = modifyAtoms' f (const (maybe Set.empty (singleton . (Source,) . DebLogComments) x)) atoms where f Source (DebLogComments y) = Just y f _ _ = Nothing -- | The @debian/control@ file. control :: Lens Atoms SourceDebDescription control = lens g s where g atoms = fromMaybe newSourceDebDescription $ foldAtoms from Nothing atoms where from Source (DebControl x') (Just x) | x /= x' = error $ "Conflicting control values:" ++ show (x, x') from Source (DebControl x) _ = Just x from _ _ x = x s x atoms = modifyAtoms' f (const ((singleton . (Source,) . DebControl) x)) atoms where f Source (DebControl y) = Just y f _ _ = Nothing -- | The @Standards-Version@ field of the @debian/control@ file standards :: Lens Atoms (Maybe StandardsVersion) standards = lens (\ a -> standardsVersion (getL control a)) (\ b a -> modL control (\ x -> x {standardsVersion = b}) a) -- | Add a stanza to the binary package's logrotate script. logrotateStanza :: Lens Atoms (Map BinPkgName (Set Text)) logrotateStanza = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHLogrotateStanza r) x = Map.insertWith Set.union b (singleton r) x from _ _ x = x s x atoms = Map.foldWithKey (\ b ts atoms'-> Set.fold (\ t atoms'' -> insertAtom (Binary b) (DHLogrotateStanza t) atoms'') atoms' ts) (deleteAtoms p atoms) x where p (Binary _) (DHLogrotateStanza _) = True p _ _ = False -- | Add entries to a binary deb's debian/foo.links file. link :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) link = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHLink loc txt) x = Map.insertWith Set.union b (singleton (loc, txt)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (loc, txt) atoms'' -> insertAtom (Binary b) (DHLink loc txt) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHLink _ _) = True p _ _ = False -- | Install files into directories by adding entries to the binary -- deb's debian/foo.install file. install :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) install = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstall src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstall src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHInstall _ _) = True p _ _ = False -- | Rename and install files. This is done by adding rules to debian/rules. installTo :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) installTo = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallTo src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallTo src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHInstallTo _ _) = True p _ _ = False -- | Install files into the a binary deb's data directory, -- /usr/share/packagename-version. This expands to either an install -- or an installTo. installData :: Lens Atoms (Map BinPkgName (Set (FilePath, FilePath))) installData = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallData src dst) x = Map.insertWith Set.union b (singleton (src, dst)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (src, dst) atoms'' -> insertAtom (Binary b) (DHInstallData src dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHInstallData _ _) = True p _ _ = False -- | Create a file in the binary deb with the given text. This is done by -- writing the file into the cabalInstall directory and adding an entry -- to the binary deb's .install file. file :: Lens Atoms (Map BinPkgName (Set (FilePath, Text))) file = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHFile path text) x = Map.insertWith Set.union b (singleton (path, text)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (path, text) atoms'' -> insertAtom (Binary b) (DHFile path text) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHFile _ _) = True p _ _ = False -- | Install a cabal executable into a binary deb. installCabalExec :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) installCabalExec = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallCabalExec name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExec name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHInstallCabalExec _ _) = True p _ _ = False -- | Rename and install a cabal executable installCabalExecTo :: Lens Atoms (Map BinPkgName (Set (String, FilePath))) installCabalExecTo = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallCabalExecTo name dst) x = Map.insertWith Set.union b (singleton (name, dst)) x from _ _ x = x s x atoms = Map.foldWithKey (\ b pairs atoms'-> Set.fold (\ (name, dst) atoms'' -> insertAtom (Binary b) (DHInstallCabalExecTo name dst) atoms'') atoms' pairs) (deleteAtoms p atoms) x where p (Binary _) (DHInstallCabalExecTo _ _) = True p _ _ = False -- | Create directories in the package installDir :: Lens Atoms (Map BinPkgName (Set FilePath)) installDir = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallDir path) x = Map.insertWith Set.union b (singleton path) x from _ _ x = x s x atoms = Map.foldWithKey (\ b paths atoms'-> Set.fold (\ path atoms'' -> insertAtom (Binary b) (DHInstallDir path) atoms'') atoms' paths) (deleteAtoms p atoms) x where p (Binary _) (DHInstallDir _) = True p _ _ = False -- | Create an /etc/init.d file in the package installInit :: Lens Atoms (Map BinPkgName Text) installInit = lens g s where g atoms = foldAtoms from Map.empty atoms where from (Binary b) (DHInstallInit text) x = Map.insertWith (error "installInit") b text x from _ _ x = x s x atoms = Map.foldWithKey (\ b text atoms'-> insertAtom (Binary b) (DHInstallInit text) atoms') (deleteAtoms p atoms) x where p (Binary _) (DHInstallInit _) = True p _ _ = False -- | Create a file in the debianization. This is used to implement the file lens above. intermediateFiles :: Lens Atoms (Set (FilePath, Text)) intermediateFiles = lens g s where g atoms = foldAtoms from Set.empty atoms where from Source (DHIntermediate path text) x = Set.insert (path, text) x from _ _ x = x s x atoms = Set.fold (\ (path, text) atoms' -> insertAtom Source (DHIntermediate path text) atoms') (deleteAtoms p atoms) x where p Source (DHIntermediate _ _) = True p _ _ = False defaultFlags :: Flags defaultFlags = Flags { verbosity_ = 1 , debAction_ = Debianize , dryRun_ = False , validate_ = False } insertAtom :: DebAtomKey -> DebAtom -> Atoms -> Atoms insertAtom mbin atom (Atoms x) = Atoms (insertWith union mbin (singleton atom) x) insertAtoms :: Set (DebAtomKey, DebAtom) -> Atoms -> Atoms insertAtoms s atoms = case maxView s of Nothing -> atoms Just ((k, a), s') -> insertAtoms s' (insertAtom k a atoms) foldAtoms :: (DebAtomKey -> DebAtom -> r -> r) -> r -> Atoms -> r foldAtoms f r0 (Atoms xs) = Map.foldWithKey (\ k s r -> Set.fold (f k) r s) r0 xs -- | Split atoms out of an Atoms by predicate. partitionAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> (Set (DebAtomKey, DebAtom), Atoms) partitionAtoms f deb = foldAtoms g (mempty, Atoms mempty) deb where g k atom (atoms, deb') = case f k atom of True -> (Set.insert (k, atom) atoms, deb') False -> (atoms, insertAtom k atom deb') deleteAtoms :: (DebAtomKey -> DebAtom -> Bool) -> Atoms -> Atoms deleteAtoms p atoms = snd (partitionAtoms p atoms) -- | Split atoms out of a Atoms by predicate. partitionAtoms' :: (Ord a) => (DebAtomKey -> DebAtom -> Maybe a) -> Atoms -> (Set a, Atoms) partitionAtoms' f deb = foldAtoms g (mempty, Atoms mempty) deb where g k atom (xs, deb') = case f k atom of Just x -> (Set.insert x xs, deb') Nothing -> (xs, insertAtom k atom deb') -- | Like modifyAtoms, but... modifyAtoms' :: (Ord a) => (DebAtomKey -> DebAtom -> Maybe a) -> (Set a -> Set (DebAtomKey, DebAtom)) -> Atoms -> Atoms modifyAtoms' f g atoms = insertAtoms (g s) atoms' where (s, atoms') = partitionAtoms' f atoms cabal-debian-3.9/src/Debian/Debianize/Files.hs0000644000175000017500000002154012236246354017233 0ustar dsfdsf-- | Convert a Debianization into a list of files that can then be -- written out. {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TupleSections #-} module Debian.Debianize.Files ( toFileMap ) where import Data.Lens.Lazy (getL) import Data.List as List (map, unlines) import Data.Map as Map (Map, toList, fromListWithKey, mapKeys) import Data.Maybe import Data.Monoid ((<>)) import Data.Set as Set (toList, member) import Data.Text as Text (Text, pack, unpack, lines, unlines, strip, null) import Debian.Control (Control'(Control, unControl), Paragraph'(Paragraph), Field'(Field)) import Debian.Debianize.Atoms (Atoms, compat, sourceFormat, watch, changelog, control, postInst, postRm, preInst, preRm, intermediateFiles, install, installDir, installInit, logrotateStanza, link, rulesHead, rulesFragments, copyright) import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), VersionControlSpec(..), XField(..), XFieldDest(..)) import Debian.Debianize.Dependencies (getRulesHead) import Debian.Debianize.Utility (showDeps') import Debian.Relation (Relations, BinPkgName(BinPkgName)) import Prelude hiding (init, unlines, writeFile) import System.FilePath (()) import Text.PrettyPrint.ANSI.Leijen (pretty) sourceFormatFiles :: Atoms -> [(FilePath, Text)] sourceFormatFiles deb = maybe [] (\ x -> [("debian/source/format", pack (show (pretty x)))]) (getL sourceFormat deb) watchFile :: Atoms -> [(FilePath, Text)] watchFile deb = maybe [] (\ x -> [("debian/watch", x)]) (getL watch deb) intermediates :: Atoms -> [(FilePath, Text)] intermediates deb = Set.toList $ getL intermediateFiles deb installs :: Atoms -> [(FilePath, Text)] installs deb = map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (src, dst) -> src <> " " <> dst) (Set.toList pairs))))) $ Map.toList $ mapKeys pathf $ getL install deb where pathf name = "debian" show (pretty name) ++ ".install" dirs :: Atoms -> [(FilePath, Text)] dirs deb = map (\ (path, dirs') -> (path, pack (List.unlines (Set.toList dirs')))) $ Map.toList $ mapKeys pathf $ getL installDir deb where pathf name = "debian" show (pretty name) ++ ".dirs" init :: Atoms -> [(FilePath, Text)] init deb = Map.toList $ mapKeys pathf $ getL installInit deb where pathf name = "debian" show (pretty name) ++ ".init" -- FIXME - use a map and insertWith, check for multiple entries logrotate :: Atoms -> [(FilePath, Text)] logrotate deb = map (\ (path, stanzas) -> (path, Text.unlines (Set.toList stanzas))) $ Map.toList $ mapKeys pathf $ getL logrotateStanza deb where pathf name = "debian" show (pretty name) ++ ".logrotate" -- | Assemble all the links by package and output one file each links :: Atoms -> [(FilePath, Text)] links deb = map (\ (path, pairs) -> (path, pack (List.unlines (map (\ (loc, txt) -> loc ++ " " ++ txt) (Set.toList pairs))))) $ Map.toList $ mapKeys pathf $ getL link deb where pathf name = "debian" show (pretty name) ++ ".links" postinstFiles :: Atoms -> [(FilePath, Text)] postinstFiles deb = Map.toList $ mapKeys pathf $ getL postInst deb where pathf (BinPkgName name) = "debian" show (pretty name) ++ ".postinst" postrmFiles :: Atoms -> [(FilePath, Text)] postrmFiles deb = Map.toList $ mapKeys pathf $ getL postRm deb where pathf name = "debian" show (pretty name) ++ ".postrm" preinstFiles :: Atoms -> [(FilePath, Text)] preinstFiles deb = Map.toList $ mapKeys pathf $ getL preInst deb where pathf name = "debian" show (pretty name) ++ ".preinst" prermFiles :: Atoms -> [(FilePath, Text)] prermFiles deb = Map.toList $ mapKeys pathf $ getL preRm deb where pathf name = "debian" show (pretty name) ++ ".prerm" -- | Turn the Debianization into a list of files, making sure the text -- associated with each path is unique. Assumes that -- finalizeDebianization has already been called. (Yes, I'm -- considering building one into the other, but it is handy to look at -- the Debianization produced by finalizeDebianization in the unit -- tests.) toFileMap :: Atoms -> Map FilePath Text toFileMap atoms = Map.fromListWithKey (\ k a b -> error $ "Multiple values for " ++ k ++ ":\n " ++ show a ++ "\n" ++ show b) $ [("debian/control", pack (show (pretty (controlFile d)))), ("debian/changelog", pack (show (pretty (fromMaybe (error "Missing debian/changelog") (getL changelog atoms))))), ("debian/rules", rules atoms), ("debian/compat", pack (show (fromMaybe (error "Missing DebCompat atom - is debhelper installed?") $ getL compat atoms) <> "\n")), ("debian/copyright", either (\ x -> pack (show (pretty x))) id (fromMaybe (error ("No DebCopyright atom: " ++ show atoms)) $ getL copyright atoms))] ++ sourceFormatFiles atoms ++ watchFile atoms ++ installs atoms ++ dirs atoms ++ init atoms ++ logrotate atoms ++ links atoms ++ postinstFiles atoms ++ postrmFiles atoms ++ preinstFiles atoms ++ prermFiles atoms ++ intermediates atoms where d = getL control atoms rules :: Atoms -> Text rules deb = Text.unlines (maybe (getRulesHead deb) id (getL rulesHead deb) : reverse (Set.toList (getL rulesFragments deb))) controlFile :: SourceDebDescription -> Control' String controlFile src = Control { unControl = (Paragraph ([Field ("Source", " " ++ show (pretty (source src))), Field ("Maintainer", " " <> show (pretty (maintainer src)))] ++ lField "Uploaders" (uploaders src) ++ (case dmUploadAllowed src of True -> [Field ("DM-Upload-Allowed", " yes")]; False -> []) ++ mField "Priority" (priority src) ++ mField "Section" (section src) ++ depField "Build-Depends" (buildDepends src) ++ depField "Build-Depends-Indep" (buildDependsIndep src) ++ depField "Build-Conflicts" (buildConflicts src) ++ depField "Build-Conflicts-Indep" (buildConflictsIndep src) ++ mField "Standards-Version" (standardsVersion src) ++ mField "Homepage" (homepage src) ++ List.map vcsField (Set.toList (vcsFields src)) ++ List.map xField (Set.toList (xFields src))) : List.map binary (binaryPackages src)) } where binary :: BinaryDebDescription -> Paragraph' String binary bin = Paragraph ([Field ("Package", " " ++ show (pretty (package bin))), Field ("Architecture", " " ++ show (pretty (architecture bin)))] ++ mField "Section" (binarySection bin) ++ mField "Priority" (binaryPriority bin) ++ bField "Essential" (essential bin) ++ relFields (relations bin) ++ [Field ("Description", " " ++ unpack (ensureDescription (description bin)))]) where ensureDescription t = case Text.lines t of [] -> "No description available." (short : long) | Text.null (strip short) -> Text.unlines ("No short description available" : long) _ -> t mField tag = maybe [] (\ x -> [Field (tag, " " <> show (pretty x))]) bField tag flag = if flag then [Field (tag, " yes")] else [] lField _ [] = [] lField tag xs = [Field (tag, " " <> show (pretty xs))] vcsField (VCSBrowser t) = Field ("Vcs-Browser", " " ++ unpack t) vcsField (VCSArch t) = Field ("Vcs-Arch", " " ++ unpack t) vcsField (VCSBzr t) = Field ("Vcs-Bzr", " " ++ unpack t) vcsField (VCSCvs t) = Field ("Vcs-Cvs", " " ++ unpack t) vcsField (VCSDarcs t) = Field ("Vcs-Darcs", " " ++ unpack t) vcsField (VCSGit t) = Field ("Vcs-Git", " " ++ unpack t) vcsField (VCSHg t) = Field ("Vcs-Hg", " " ++ unpack t) vcsField (VCSMtn t) = Field ("Vcs-Mtn", " " ++ unpack t) vcsField (VCSSvn t) = Field ("Vcs-Svn", " " ++ unpack t) xField (XField dests tag t) = Field (unpack ("X" <> showDests dests <> "-" <> tag), unpack (" " <> t)) showDests s = if member B s then "B" else "" <> if member S s then "S" else "" <> if member C s then "C" else "" relFields :: PackageRelations -> [Field' [Char]] relFields rels = depField "Depends" (depends rels) ++ depField "Recommends" (recommends rels) ++ depField "Suggests" (suggests rels) ++ depField "Pre-Depends" (preDepends rels) ++ depField "Breaks" (breaks rels) ++ depField "Conflicts" (conflicts rels) ++ depField "Provides" (provides_ rels) ++ depField "Replaces" (replaces_ rels) ++ depField "Built-Using" (builtUsing rels) depField :: [Char] -> Relations -> [Field' [Char]] depField tag rels = case rels of [] -> []; _ -> [Field (tag, " " ++ showDeps' (tag ++ ":") rels)] cabal-debian-3.9/src/Debian/Debianize/Details.hs0000644000175000017500000000406712236246354017563 0ustar dsfdsf{-# OPTIONS -Wall #-} module Debian.Debianize.Details ( debianDefaultAtoms , seereasonDefaultAtoms ) where import Data.Lens.Lazy (modL, setL) import Data.Map as Map (fromList) import Data.Monoid (mempty) import Data.Set as Set (insert) import Debian.Relation (BinPkgName(BinPkgName)) import Data.Version (Version(Version)) import Debian.Debianize (Atoms, missingDependencies, epochMap) import Debian.Debianize.VersionSplits (mapCabal, splitCabal) import Distribution.Package (PackageName(PackageName)) debianDefaultAtoms :: Atoms debianDefaultAtoms = setL epochMap (Map.fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . mapCabal (PackageName "parsec") "parsec3" . splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . mapCabal (PackageName "QuickCheck") "quickcheck2" . mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ mempty seereasonDefaultAtoms :: Atoms seereasonDefaultAtoms = modL missingDependencies (Set.insert (BinPkgName "libghc-happstack-authenticate-9-doc")) . splitCabal (PackageName "clckwrks") "clckwrks-13" (Version [0, 14] []) . splitCabal (PackageName "clckwrks") "clckwrks-14" (Version [0, 15] []) . mapCabal (PackageName "clckwrks") "clckwrks" . splitCabal (PackageName "blaze-html") "blaze-html-5" (Version [0, 6] []) . mapCabal (PackageName "blaze-html") "blaze-html" . splitCabal (PackageName "happstack-authenticate") "happstack-authenticate-9" (Version [0, 10] []) . mapCabal (PackageName "happstack-authenticate") "happstack-authenticate" . splitCabal (PackageName "http-types") "http-types-7" (Version [0, 8] []) . mapCabal (PackageName "http-types") "http-types" . splitCabal (PackageName "web-plugins") "web-plugins-1" (Version [0, 2] []) . mapCabal (PackageName "web-plugins") "web-plugins" . splitCabal (PackageName "case-insensitive") "case-insensitive-0" (Version [1] []) . mapCabal (PackageName "case-insensitive") "case-insensitive" $ debianDefaultAtoms cabal-debian-3.9/src/Debian/Debianize/Finalize.hs0000644000175000017500000004204412236246354017734 0ustar dsfdsf-- | Convert a Debianization into a list of files that can then be -- written out. {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Debian.Debianize.Finalize ( finalizeDebianization ) where import Data.ByteString.Lazy.UTF8 (fromString) import Data.Char (toLower) import Data.Digest.Pure.MD5 (md5) import Data.Lens.Lazy (setL, getL, modL) import Data.List as List (map) import Data.Map as Map (insertWith, foldWithKey, elems) import Data.Maybe import Data.Monoid (mempty, (<>)) import Data.Set as Set (Set, difference, fromList, null, insert, toList, filter, fold, map, union, singleton) import Data.Text as Text (pack, unlines, unpack) import Debian.Debianize.Atoms as Atoms (Atoms, packageDescription, control, binaryArchitectures, rulesFragments, website, serverInfo, link, backups, executable, sourcePriority, sourceSection, binaryPriorities, binarySections, description, install, installTo, installData, installCabalExecTo, noProfilingLibrary, noDocumentationLibrary, utilsPackageNames, extraDevDeps, installData, installCabalExec, file, apacheSite, installDir, buildDir, dataDir, intermediateFiles) import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), newBinaryDebDescription, modifyBinaryDeb, PackageType(Exec, Development, Profiling, Documentation, Utilities)) import Debian.Debianize.Dependencies (debianName, binaryPackageDeps, binaryPackageConflicts, binaryPackageProvides, binaryPackageReplaces, putBuildDeps) import Debian.Debianize.Goodies (describe, siteAtoms, serverAtoms, backupAtoms, execAtoms) import Debian.Debianize.Types (InstallFile(..)) import Debian.Policy (PackageArchitectures(Any, All), Section(..)) import Debian.Relation (Relation(Rel), BinPkgName(BinPkgName)) import Distribution.Package (PackageName(PackageName), PackageIdentifier(..)) import qualified Distribution.PackageDescription as Cabal import Prelude hiding (init, unlines, writeFile, map, log) import System.FilePath ((), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName) import Text.PrettyPrint.ANSI.Leijen (pretty) -- | Now that we know the build and data directories, we can expand -- some atoms into sets of simpler atoms which can eventually be -- turned into the files of the debianization. The original atoms are -- not removed from the list because they may contribute to the -- debianization in other ways, so be careful not to do this twice, -- this function is not idempotent. (Exported for use in unit tests.) finalizeDebianization :: Atoms -> Atoms finalizeDebianization atoms0 = g $ finalizeAtoms $ makeUtilsPackage $ librarySpecs $ putBuildDeps $ f $ finalizeAtoms $ atoms0 where -- Create the binary packages for the web sites, servers, backup packges, and other executables f :: Atoms -> Atoms f atoms = (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL website atoms)) . (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL serverInfo atoms)) . (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> modL binaryArchitectures (Map.insertWith (flip const) b Any) . cabalExecBinaryPackage b $ atoms'') atoms' (getL backups atoms)) . (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL executable atoms)) $ atoms -- Turn atoms related to priority, section, and description into debianization elements g :: Atoms -> Atoms g atoms = (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {priority = Just x}) atoms') (getL sourcePriority atoms)) . (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {section = Just x}) atoms') (getL sourceSection atoms)) . (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {architecture = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryArchitectures atoms)) . (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binaryPriority = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryPriorities atoms)) . (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binarySection = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binarySections atoms)) . (\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {Debian.description = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL Atoms.description atoms)) $ atoms cabalExecBinaryPackage :: BinPkgName -> Atoms -> Atoms cabalExecBinaryPackage b deb = modL control (\ y -> y {binaryPackages = bin : binaryPackages y}) deb where bin = BinaryDebDescription { Debian.package = b , architecture = Any , binarySection = Just (MainSection "misc") , binaryPriority = Nothing , essential = False , Debian.description = describe deb Exec (Cabal.package pkgDesc) , relations = binaryPackageRelations b Exec deb } pkgDesc = fromMaybe (error "cabalExecBinaryPackage: no PackageDescription") $ getL packageDescription deb binaryPackageRelations :: BinPkgName -> PackageType -> Atoms -> PackageRelations binaryPackageRelations b typ deb = PackageRelations { Debian.depends = [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++ (if typ == Development then List.map (: []) (toList (getL extraDevDeps deb)) else []) ++ binaryPackageDeps b deb , recommends = [anyrel "${haskell:Recommends}"] , suggests = [anyrel "${haskell:Suggests}"] , preDepends = [] , breaks = [] , conflicts = [anyrel "${haskell:Conflicts}"] ++ binaryPackageConflicts b deb , provides_ = [anyrel "${haskell:Provides}"] ++ binaryPackageProvides b deb , replaces_ = [anyrel "${haskell:Replaces}"] ++ binaryPackageReplaces b deb , builtUsing = [] } -- debLibProf haddock binaryPackageDeps extraDevDeps extraLibMap librarySpecs :: Atoms -> Atoms librarySpecs deb | isNothing (getL packageDescription deb) = deb librarySpecs deb = (if doc then modL link (Map.insertWith Set.union debName (singleton ("/usr/share/doc" show (pretty debName) "html" cabal <.> "txt", "/usr/lib/ghc-doc/hoogle" hoogle <.> "txt"))) else id) $ modL control (\ y -> y { binaryPackages = (if dev then [librarySpec deb Any Development (Cabal.package pkgDesc)] else []) ++ (if prof then [librarySpec deb Any Profiling (Cabal.package pkgDesc)] else []) ++ (if doc then [docSpecsParagraph deb (Cabal.package pkgDesc)] else []) ++ (binaryPackages y) }) deb where doc = dev && not (getL noDocumentationLibrary deb) prof = dev && not (getL noProfilingLibrary deb) dev = isJust (Cabal.library pkgDesc) pkgDesc = fromMaybe (error "librarySpecs: no PackageDescription") $ getL packageDescription deb PackageName cabal = pkgName (Cabal.package pkgDesc) debName :: BinPkgName debName = debianName deb Documentation (Cabal.package pkgDesc) hoogle = List.map toLower cabal docSpecsParagraph :: Atoms -> PackageIdentifier -> BinaryDebDescription docSpecsParagraph atoms pkgId = BinaryDebDescription { Debian.package = debianName atoms Documentation pkgId , architecture = All , binarySection = Just (MainSection "doc") , binaryPriority = Nothing , essential = False , Debian.description = describe atoms Documentation pkgId , relations = binaryPackageRelations (debianName atoms Documentation pkgId) Development atoms } librarySpec :: Atoms -> PackageArchitectures -> PackageType -> PackageIdentifier -> BinaryDebDescription librarySpec atoms arch typ pkgId = BinaryDebDescription { Debian.package = debianName atoms typ pkgId , architecture = arch , binarySection = Nothing , binaryPriority = Nothing , essential = False , Debian.description = describe atoms typ pkgId , relations = binaryPackageRelations (debianName atoms typ pkgId) Development atoms } -- | Create a package to hold any executables and data files not -- assigned to some other package. makeUtilsPackage :: Atoms -> Atoms makeUtilsPackage deb | isNothing (getL packageDescription deb) = deb makeUtilsPackage deb = case (Set.difference availableData installedData, Set.difference availableExec installedExec) of (datas, execs) | Set.null datas && Set.null execs -> deb (datas, execs) -> let ps = fromMaybe (singleton (debianName deb Utilities (Cabal.package pkgDesc))) (getL utilsPackageNames deb) deb' = Set.fold (h datas execs) deb ps in -- deb' = setL packageDescription (Just pkgDesc) (makeUtilsAtoms p datas execs deb) in Set.fold (g execs) deb' ps -- modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb' where h datas execs p deb' = setL packageDescription (Just pkgDesc) (makeUtilsAtoms p datas execs deb') g execs p deb' = modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb' f _ _ _ (Just bin) = bin f deb' p arch Nothing = let bin = newBinaryDebDescription p arch in bin {binarySection = Just (MainSection "misc"), relations = binaryPackageRelations p Utilities deb'} pkgDesc = fromMaybe (error "makeUtilsPackage: no PackageDescription") $ getL packageDescription deb availableData = Set.fromList (Cabal.dataFiles pkgDesc) availableExec = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc))) installedData :: Set FilePath installedData = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL install deb) <> (List.map fst . concat . List.map toList . elems $ getL installTo deb) <> (List.map fst . concat . List.map toList . elems $ getL installData deb)) installedExec :: Set String installedExec = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL installCabalExec deb) <> (List.map fst . concat . List.map toList . elems $ getL installCabalExecTo deb) <> (List.map ename . elems $ getL executable deb)) where ename i = case sourceDir i of (Nothing) -> execName i (Just s) -> s execName i -- installedExec = foldCabalExecs (Set.insert :: String -> Set String -> Set String) (Set.empty :: Set String) deb makeUtilsAtoms :: BinPkgName -> Set FilePath -> Set String -> Atoms -> Atoms makeUtilsAtoms p datas execs atoms0 = if Set.null datas && Set.null execs then atoms0 else modL rulesFragments (Set.insert (pack ("build" show (pretty p) ++ ":: build-ghc-stamp\n"))) . g $ atoms0 where g :: Atoms -> Atoms g atoms = Set.fold execAtom (Set.fold dataAtom atoms datas) execs dataAtom path atoms = modL installData (insertWith union p (singleton (path, path))) atoms execAtom name atoms = modL installCabalExec (insertWith union p (singleton (name, "usr/bin"))) atoms anyrel :: String -> [Relation] anyrel x = anyrel' (BinPkgName x) anyrel' :: BinPkgName -> [Relation] anyrel' x = [Rel x Nothing Nothing] finalizeAtoms :: Atoms -> Atoms finalizeAtoms atoms | atoms == mempty = atoms finalizeAtoms atoms = atoms <> finalizeAtoms (expandAtoms atoms) expandAtoms :: Atoms -> Atoms expandAtoms old = expandApacheSite . expandInstallCabalExec . expandInstallCabalExecTo . expandInstallData . expandInstallTo . expandFile . expandWebsite . expandServer . expandBackups . expandExecutable $ mempty where expandApacheSite :: Atoms -> Atoms expandApacheSite new = foldWithKey (\ b (dom, log, text) atoms -> modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom))) . modL installDir (Map.insertWith Set.union b (singleton log)) . modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" dom, text))) $ atoms) new (getL apacheSite old) expandInstallCabalExec :: Atoms -> Atoms expandInstallCabalExec new = foldWithKey (\ b pairs atoms -> Set.fold (\ (name, dst) atoms' -> modL install (Map.insertWith Set.union b (singleton (builddir name name, dst))) atoms') atoms pairs) new (getL installCabalExec old) where builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old) expandInstallCabalExecTo :: Atoms -> Atoms expandInstallCabalExecTo new = foldWithKey (\ b pairs atoms -> Set.fold (\ (n, d) atoms' -> modL rulesFragments (Set.insert (Text.unlines [ pack ("binary-fixup" show (pretty b)) <> "::" , "\tinstall -Dps " <> pack (builddir n n) <> " " <> pack ("debian" show (pretty b) makeRelative "/" d) ])) atoms') atoms pairs) new (getL installCabalExecTo old) where builddir = fromMaybe {-(error "finalizeAtoms: no buildDir")-} "dist-ghc/build" (getL buildDir old) expandInstallData :: Atoms -> Atoms expandInstallData new = foldWithKey (\ b pairs atoms -> Set.fold (\ (s, d) atoms' -> if takeFileName s == takeFileName d then modL install (Map.insertWith Set.union b (singleton (s, datadir makeRelative "/" (takeDirectory d)))) atoms' else modL installTo (Map.insertWith Set.union b (singleton (s, datadir makeRelative "/" d))) atoms') atoms pairs) new (getL installData old) where datadir = fromMaybe (error "finalizeAtoms: no dataDir") $ getL dataDir old expandInstallTo :: Atoms -> Atoms expandInstallTo new = foldWithKey (\ p pairs atoms -> Set.fold (\ (s, d) atoms' -> modL rulesFragments (Set.insert (Text.unlines [ pack ("binary-fixup" show (pretty p)) <> "::" , "\tinstall -Dp " <> pack s <> " " <> pack ("debian" show (pretty p) makeRelative "/" d) ])) atoms') atoms pairs) new (getL installTo old) expandFile :: Atoms -> Atoms expandFile new = foldWithKey (\ p pairs atoms -> Set.fold (\ (path, s) atoms' -> let (destDir', destName') = splitFileName path tmpDir = "debian/cabalInstall" show (md5 (fromString (unpack s))) tmpPath = tmpDir destName' in modL intermediateFiles (Set.insert (tmpPath, s)) . modL install (Map.insertWith Set.union p (singleton (tmpPath, destDir'))) $ atoms') atoms pairs) new (getL file old) expandWebsite :: Atoms -> Atoms expandWebsite new = foldWithKey siteAtoms new (getL website old) expandServer :: Atoms -> Atoms expandServer new = foldWithKey (\ b x atoms -> serverAtoms b x False atoms) new (getL serverInfo old) expandBackups :: Atoms -> Atoms expandBackups new = foldWithKey backupAtoms new (getL backups old) expandExecutable :: Atoms -> Atoms expandExecutable new = foldWithKey execAtoms new (getL executable old) cabal-debian-3.9/src/Debian/Debianize/Interspersed.hs0000644000175000017500000000477612236246354020654 0ustar dsfdsf-- | A class used while converting Cabal dependencies into Debian -- dependencies. {-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, StandaloneDeriving, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall -Werror #-} module Debian.Debianize.Interspersed ( Interspersed(..) ) where import Debug.Trace -- | A class of Bs insterspersed with Cs. It is used when converting -- the cabal dependencies to debian, where the "around" type is the -- binary package name and the "between" type is the version number. -- -- Minimum implementation is a method to return the leftmost B, and -- another to return the following (C,B) pairs. Its unfortunate to -- require lists in the implementation, a fold function would be -- better (though I find implementing such folds to be a pain in the -- you-know-what.) -- -- The class provides implementations of three folds, each of which -- exposes slightly different views of the data. class Interspersed t around between | t -> around, t -> between where leftmost :: t -> around pairs :: t -> [(between, around)] foldTriples :: (around -> between -> around -> r -> r) -> r -> t -> r foldTriples f r0 x = snd $ foldl (\ (b1, r) (c, b2) -> (b1, f b1 c b2 r)) (leftmost x, r0) (pairs x) -- Treat the b's as the centers and the c's as the things to their -- left and right. Use Maybe to make up for the missing c's at the -- ends. foldInverted :: (Maybe between -> around -> Maybe between -> r -> r) -> r -> t -> r foldInverted f r0 x = (\ (bn, an, r) -> f bn an Nothing r) $ foldl g (Nothing, leftmost x, r0) (pairs x) where g (b1, a1, r) (b2, a2) = (Just b2, a2, f b1 a1 (Just b2) r) foldArounds :: (around -> around -> r -> r) -> r -> t -> r foldArounds f r0 x = snd $ foldl (\ (a1, r) (_, a2) -> (a2, f a1 a2 r)) (leftmost x, r0) (pairs x) foldBetweens :: (between -> r -> r) -> r -> t -> r foldBetweens f r0 x = foldl (\ r (b, _) -> (f b r)) r0 (pairs x) -- | An example data Splits = Splits Double [(String, Double)] deriving Show instance Interspersed Splits Double String where leftmost (Splits x _) = x pairs (Splits _ x) = x _splits :: Splits _splits = Splits 1.0 [("between 1 and 2", 2.0), ("between 2 and 3", 3.0)] _test1 :: () _test1 = foldTriples (\ l s r () -> trace ("l=" ++ show l ++ " s=" ++ show s ++ " r=" ++ show r) ()) () _splits _test2 :: () _test2 = foldInverted (\ sl f sr () -> trace ("sl=" ++ show sl ++ " f=" ++ show f ++ " sr=" ++ show sr) ()) () _splits cabal-debian-3.9/src/Debian/Debianize/VersionSplits.hs0000644000175000017500000000226212236246354021015 0ustar dsfdsfmodule Debian.Debianize.VersionSplits ( mapCabal , splitCabal ) where import Data.Lens.Lazy (modL) import Data.Map as Map (alter) import Data.Version (Version) import Debian.Debianize.Atoms (Atoms, debianNameMap) import Debian.Debianize.Types.VersionSplits (VersionSplits, makePackage, insertSplit) import Distribution.Package (PackageName) -- | Add a VersionSplits value to 'atoms' that maps the given cabal -- name 'pname' to the given debian name 'dname'. mapCabal :: PackageName -> String -> Atoms -> Atoms mapCabal pname dname atoms = modL debianNameMap (Map.alter f pname) atoms where f :: Maybe VersionSplits -> Maybe VersionSplits f Nothing = Just (makePackage dname) f (Just sp) = error $ "mapCabal - already mapped: " ++ show sp -- | Map the versions of 'pname' less than 'ver' to the given debian -- name 'ltname'. splitCabal :: PackageName -> String -> Version -> Atoms -> Atoms splitCabal pname ltname ver atoms = modL debianNameMap (Map.alter f pname) atoms where f :: Maybe VersionSplits -> Maybe VersionSplits f Nothing = error $ "splitCabal - not mapped: " ++ show pname f (Just sp) = Just (insertSplit ver ltname sp) cabal-debian-3.9/src/Distribution/0000755000175000017500000000000012236246354015236 5ustar dsfdsfcabal-debian-3.9/src/Distribution/Version/0000755000175000017500000000000012236246354016663 5ustar dsfdsfcabal-debian-3.9/src/Distribution/Version/Invert.hs0000644000175000017500000000414712236246354020474 0ustar dsfdsf{-# OPTIONS_GHC -Wall #-} module Distribution.Version.Invert ( invertVersionRange , invertVersionIntervals ) where import Distribution.Version (Version(Version, versionBranch, versionTags), VersionRange, fromVersionIntervals, asVersionIntervals, mkVersionIntervals, LowerBound(LowerBound), UpperBound(UpperBound, NoUpperBound), Bound(InclusiveBound, ExclusiveBound)) -- | This function belongs in Cabal, see http://hackage.haskell.org/trac/hackage/ticket/935. invertVersionRange :: VersionRange -> VersionRange invertVersionRange = fromVersionIntervals . maybe (error "invertVersionRange") id . mkVersionIntervals . invertVersionIntervals . asVersionIntervals invertVersionIntervals :: [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] invertVersionIntervals xs = case xs of [] -> [(lb0, NoUpperBound)] ((LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound, ub) : more) -> invertVersionIntervals' ub more ((lb, ub) : more) -> (lb0, invertLowerBound lb) : invertVersionIntervals' ub more where invertVersionIntervals' :: UpperBound -> [(LowerBound, UpperBound)] -> [(LowerBound, UpperBound)] invertVersionIntervals' NoUpperBound [] = [] invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] invertVersionIntervals' ub0 [(lb, NoUpperBound)] = [(invertUpperBound ub0, invertLowerBound lb)] invertVersionIntervals' ub0 ((lb, ub1) : more) = (invertUpperBound ub0, invertLowerBound lb) : invertVersionIntervals' ub1 more invertLowerBound :: LowerBound -> UpperBound invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) invertUpperBound :: UpperBound -> LowerBound invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" invertBound :: Bound -> Bound invertBound ExclusiveBound = InclusiveBound invertBound InclusiveBound = ExclusiveBound lb0 :: LowerBound lb0 = LowerBound (Version {versionBranch = [0], versionTags = []}) InclusiveBound cabal-debian-3.9/src/CabalDebian.hs0000644000175000017500000000230712236246354015222 0ustar dsfdsf-- | This is the main function of the cabal-debian executable. This -- is generally run by the autobuilder to debianize packages that -- don't have any custom debianization code in Setup.hs. This is a -- less flexible and powerful method than calling the debianize -- function directly, many sophisticated configuration options cannot -- be accessed using the command line interface. import Data.Lens.Lazy (setL) import Data.Map as Map (fromList) import Data.Monoid (mempty) import Data.Version (Version(Version)) import Debian.Debianize.Atoms (Atoms, epochMap) import Debian.Debianize.Debianize (cabalDebian) import Debian.Debianize.VersionSplits (mapCabal, splitCabal) import Distribution.Package (PackageName(PackageName)) main :: IO () main = cabalDebian defaultAtoms defaultAtoms :: Atoms defaultAtoms = setL epochMap (fromList [(PackageName "HaXml", 1), (PackageName "HTTP", 1)]) . splitCabal (PackageName "parsec") "parsec2" (Version [3] []) . mapCabal (PackageName "parsec") "parsec3" . splitCabal (PackageName "QuickCheck") "quickcheck1" (Version [2] []) . mapCabal (PackageName "QuickCheck") "quickcheck2" . mapCabal (PackageName "gtk2hs-buildtools") "gtk2hs-buildtools" $ mempty cabal-debian-3.9/debian/0000755000175000017500000000000012236246354013212 5ustar dsfdsfcabal-debian-3.9/debian/copyright0000644000175000017500000000337312236246354015153 0ustar dsfdsfThis package was debianized by David Fox on September 18, 2007. The packageing was adjusted to Debian conventions by Joachim Breitner on Sat, 01 May 2010 21:16:18 +0200, and is licenced under the same terms as the package itself.. Copyright (c) 2007, David Fox Copyright (c) 2007, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cabal-debian-3.9/debian/Debianize.hs0000644000175000017500000001003112236246354015433 0ustar dsfdsf{-# LANGUAGE OverloadedStrings #-} import Data.Lens.Lazy import Data.Map as Map (insertWith) import Data.Maybe (fromMaybe) import Data.Set as Set (insert, union, singleton) import Data.Text as Text (intercalate) import Debian.Debianize as Atoms import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) import Debian.Debianize.Details (seereasonDefaultAtoms) import Debian.Relation (BinPkgName(BinPkgName), Relation(Rel), VersionReq(SLT, GRE)) import Debian.Version (parseDebianVersion) import Prelude hiding (log) import System.Directory (copyFile) main :: IO () main = do -- Copy the changelog into the top directory so that hackage -- will see it. copyFile "debian/changelog" "changelog" log <- inputChangeLog (Top ".") new <- debianization (Top ".") (return . customize . setL changelog (Just log)) seereasonDefaultAtoms old <- inputDebianization (Top ".") case compareDebianization old (copyFirstLogEntry old new) of "" -> return () s -> error $ "Debianization mismatch:\n" ++ s -- This would overwrite the existing debianization rather than -- just make sure it matches: -- writeDebianization "." new where customize = (modL control (\ y -> y {homepage = Just "http://src.seereason.com/cabal-debian"}) . setL compat (Just 7) . setL standards (Just (StandardsVersion 3 9 3 Nothing)) . setL sourceFormat (Just Native3) . -- modL extraDevDeps (Set.insert (BinPkgName "debian-policy")) . setL utilsPackageNames (Just (singleton (BinPkgName "cabal-debian"))) . modL installCabalExec (Map.insertWith union (BinPkgName "cabal-debian-tests") (singleton ("cabal-debian-tests", "/usr/bin"))) . modL depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "apt-file") Nothing Nothing))) . modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) . modL Atoms.depends (Map.insertWith union (BinPkgName "libghc-cabal-debian-dev") (singleton (Rel (BinPkgName "debian-policy") Nothing Nothing))) . modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "debhelper") Nothing Nothing))) . modL Atoms.depends (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8.19" :: String)))) Nothing))) . modL conflicts (Map.insertWith union (BinPkgName "cabal-debian") (singleton (Rel (BinPkgName "haskell-debian-utils") (Just (SLT (parseDebianVersion ("3.59" :: String)))) Nothing))) . modL description (Map.insertWith (error "test7") (BinPkgName "cabal-debian") (Text.intercalate "\n" [ "Create a debianization for a cabal package" , " Tool for creating debianizations of Haskell packages based on the .cabal" , " file. If apt-file is installed it will use it to discover what is the" , " debian package name of a C library." , " ." , " Author: David Fox " , " Upstream-Maintainer: David Fox " ]))) -- | This copies the first log entry of deb1 into deb2. Because the -- debianization process updates that log entry, we need to undo that -- update in order to get a clean comparison. copyFirstLogEntry :: Atoms -> Atoms -> Atoms copyFirstLogEntry deb1 deb2 = modL changelog (const (Just (ChangeLog (hd1 : tl2)))) deb2 where ChangeLog (hd1 : _) = fromMaybe (error "Missing debian/changelog") (getL changelog deb1) ChangeLog (_ : tl2) = fromMaybe (error "Missing debian/changelog") (getL changelog deb2)