diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -587,7 +587,7 @@ test7 label = TestLabel label $ TestCase (do new <- readProcessWithExitCode "runhaskell" ["--ghc-arg=-package-db=dist/package.conf.inplace", "debian/Debianize.hs", "--dry-run", "--native"] "" - assertEqual label (ExitSuccess, "", "Ignored: debian/cabal-debian.1\nIgnored: debian/cabal-debian.manpages\n") new) + assertEqual label (ExitSuccess, "Ignored: debian/cabal-debian.1\nIgnored: debian/cabal-debian.manpages\nDebianization (dry run):\ndebian/cabal-debian-tests.install: Deleted\n\n", "") new) test8 :: String -> Test test8 label = diff --git a/cabal-debian.cabal b/cabal-debian.cabal --- a/cabal-debian.cabal +++ b/cabal-debian.cabal @@ -1,5 +1,5 @@ Name: cabal-debian -Version: 4.24.9 +Version: 4.25 Copyright: Copyright (c) 2007-2014, David Fox, Jeremy Shaw License: BSD3 License-File: LICENSE @@ -164,6 +164,7 @@ deepseq, Diff >= 0.3.1, directory, + exceptions, filepath, hsemail, HUnit, @@ -179,9 +180,10 @@ syb, text, unix, - Unixutils, + Unixutils >= 1.53, utf8-string Exposed-Modules: + Data.Maybe.Extended Debian.GHC Debian.Policy Distribution.Version.Invert @@ -276,7 +278,7 @@ Hs-Source-Dirs: . Main-is: CabalDebian.hs ghc-options: -threaded -Wall -O2 - Build-Depends: base, cabal-debian, Cabal >= 1.18, lens, mtl, pretty + Build-Depends: base, cabal-debian, Cabal >= 1.18, lens, mtl, pretty, Unixutils >= 1.53 if flag(pretty-112) Build-Depends: pretty >= 1.1.2 else diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,17 +1,3 @@ -haskell-cabal-debian (4.24.8) unstable; urgency=low - - * use ghcjs --numeric-ghc-version to set the compilerInfoCompat field - of CompilerInfo. This makes cabal file directives like impl(ghc >= 7.9) - work for ghcjs packages. - - -- David Fox Sun, 29 Mar 2015 12:38:33 -0700 - -haskell-cabal-debian (4.24.7) unstable; urgency=low - - * Remove the Data.Algorithm.Diff modules, they have moved into Diff-0.3.1 - - -- David Fox Tue, 24 Mar 2015 16:51:29 -0700 - haskell-cabal-debian (4.24.6) unstable; urgency=low * Use build dependency haskell-devscripts >= 0.8 for unofficial, >= 0.9 diff --git a/debian-haskell/Debian/Control/Text.hs b/debian-haskell/Debian/Control/Text.hs --- a/debian-haskell/Debian/Control/Text.hs +++ b/debian-haskell/Debian/Control/Text.hs @@ -92,7 +92,7 @@ where hasFieldName :: String -> Field' T.Text -> Bool hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' hasFieldName _ _ = False - stripWS = T.reverse . T.strip . T.reverse . T.strip + stripWS = T.strip protectFieldText = protectFieldText' asString = T.unpack diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,11 @@ +haskell-cabal-debian (4.25) unstable; urgency=low + + * Make sure /proc is mounted when we run ghc to determine its version + number. This is only a concern when running in a build root. + * Fix whitespace handling bugs in copyright file parser and renderer. + + -- David Fox Sun, 05 Apr 2015 08:14:09 -0700 + haskell-cabal-debian (4.24.9) unstable; urgency=low * Make debian/Debianize.hs a standard debianization script diff --git a/src/Data/Maybe/Extended.hs b/src/Data/Maybe/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Extended.hs @@ -0,0 +1,9 @@ +module Data.Maybe.Extended ( + module Data.Maybe, + nothingIf + ) where + +import Data.Maybe + +nothingIf :: (a -> Bool) -> a -> Maybe a +nothingIf p x = if p x then Nothing else Just x diff --git a/src/Debian/Debianize/CabalInfo.hs b/src/Debian/Debianize/CabalInfo.hs --- a/src/Debian/Debianize/CabalInfo.hs +++ b/src/Debian/Debianize/CabalInfo.hs @@ -19,8 +19,9 @@ import Control.Category ((.)) import Control.Lens.TH (makeLenses) +import Control.Monad.Catch (MonadMask) import Control.Monad.State (execStateT) -import Control.Monad.Trans (liftIO) +import Control.Monad.Trans (MonadIO, liftIO) import Data.Generics (Data, Typeable) import Data.Map as Map (Map) import Data.Monoid (Monoid(..)) @@ -39,6 +40,7 @@ import Distribution.Package (PackageName) import Distribution.PackageDescription as Cabal (PackageDescription(homepage)) import Prelude hiding ((.), init, init, log, log, null) +import System.Unix.Mount (withProcAndSys) -- This enormous record is a mistake - instead it should be an Atom -- type with lots of constructors, and the Atoms type is a set of @@ -83,8 +85,8 @@ -- | Given the 'Flags' value read the cabalization and build a new -- 'CabalInfo' record. -newCabalInfo :: Flags -> IO CabalInfo -newCabalInfo flags' = do +newCabalInfo :: (MonadIO m, MonadMask m) => Flags -> m CabalInfo +newCabalInfo flags' = withProcAndSys "/" $ do pkgDesc <- inputCabalization flags' copyrt <- liftIO $ defaultCopyrightDescription pkgDesc execStateT diff --git a/src/Debian/Debianize/CopyrightDescription.hs b/src/Debian/Debianize/CopyrightDescription.hs --- a/src/Debian/Debianize/CopyrightDescription.hs +++ b/src/Debian/Debianize/CopyrightDescription.hs @@ -27,17 +27,19 @@ import Data.Char (isSpace) import Data.Default (Default(def)) +import Data.Either (lefts, rights) import Data.Generics (Data, Typeable) import Control.Lens.TH (makeLenses) import Data.List as List (dropWhileEnd, partition) -import Data.Maybe (isJust, catMaybes, fromJust, fromMaybe, listToMaybe) +import Data.Maybe.Extended (isJust, catMaybes, fromJust, fromMaybe, listToMaybe, nothingIf) import Data.Monoid ((<>), mempty) import Data.Text as Text (Text, pack, strip, unpack, null, lines, unlines, dropWhileEnd) -import Debian.Control (Field'(Field), lookupP, Paragraph'(Paragraph), Control'(Control, unControl), parseControl) +import Debian.Control (Field'(Field), fieldValue, Paragraph'(Paragraph), Control'(Control, unControl), parseControl) import Debian.Debianize.Prelude (readFileMaybe) import Debian.Orphans () import Debian.Policy (License(..), readLicense, fromCabalLicense) import Debian.Pretty (prettyText, ppText) +import Debug.Trace import qualified Distribution.License as Cabal (License(UnknownLicense)) import qualified Distribution.Package as Cabal #if MIN_VERSION_Cabal(1,20,0) @@ -111,41 +113,41 @@ -- | Try to parse a structured copyright file parseCopyrightDescription :: [Paragraph' Text] -> Maybe CopyrightDescription parseCopyrightDescription (hd : tl) = - let (muri :: Maybe URI) = maybe Nothing (\ (Field (_, t)) -> parseURI . unpack $ t) (lookupP "Format" hd) in + let (muri :: Either (Paragraph' Text) URI) = maybe (Left hd) Right (maybe Nothing (parseURI . unpack) (fieldValue "Format" hd)) in case (muri, map parseFilesOrLicense tl) of - (Just uri, fnls) | all isJust fnls -> + (Right uri, fnls) | all (either (const False) (const True)) fnls -> Just $ CopyrightDescription { _format = uri - , _upstreamName = fmap (\ (Field (_, x)) -> x) $ lookupP "Upstream-Name" hd - , _upstreamContact = fmap (\ (Field (_, x)) -> x) $ lookupP "Upstream-Contact" hd - , _upstreamSource = fmap (\ (Field (_, x)) -> x) $ lookupP "Source" hd - , _disclaimer = fmap (\ (Field (_, x)) -> x) $ lookupP "Disclaimer" hd - , _summaryComment = fmap (\ (Field (_, x)) -> x) $ lookupP "Comment" hd - , _summaryLicense = fmap (\ (Field (_, x)) -> readLicense x) $ lookupP "License" hd - , _summaryCopyright = Nothing -- fmap (\ (Field (_, x)) -> x) $ lookupP "Copyright" hd - , _filesAndLicenses = catMaybes fnls + , _upstreamName = fieldValue "Upstream-Name" hd + , _upstreamContact = fieldValue "Upstream-Contact" hd + , _upstreamSource = fieldValue "Source" hd + , _disclaimer = fieldValue "Disclaimer" hd + , _summaryComment = fieldValue "Comment" hd + , _summaryLicense = fmap readLicense (fieldValue "License" hd) + , _summaryCopyright = Nothing -- fieldValue "Copyright" hd + , _filesAndLicenses = rights fnls } - _ -> Nothing + (_, fnls) -> trace ("Not a parsable copyright file: " ++ show (lefts [muri] ++ lefts fnls)) Nothing parseCopyrightDescription [] = Nothing -parseFilesOrLicense :: Paragraph' Text -> Maybe (FilesOrLicenseDescription) +parseFilesOrLicense :: Paragraph' Text -> Either (Paragraph' Text) (FilesOrLicenseDescription) parseFilesOrLicense p = - case (lookupP "Files" p, lookupP "Copyright" p, lookupP "License" p) of - (Just (Field (_, files)), - Just (Field (_, copyright)), - Just (Field (_, license))) -> - Just $ FilesDescription - { _filesPattern = unpack files - , _filesCopyright = copyright - , _filesLicense = readLicense license - , _filesComment = maybe Nothing (\ (Field (_, comment)) -> Just comment) (lookupP "Comment" p) } + case (fieldValue "Files" p, fieldValue "Copyright" p, fieldValue "License" p) of + (Just files, + Just copyright, + Just license) -> + Right $ FilesDescription + { _filesPattern = unpack files + , _filesCopyright = copyright + , _filesLicense = readLicense license + , _filesComment = fieldValue "Comment" p } (Nothing, Nothing, - Just (Field (_, license))) -> - Just $ LicenseDescription - { _license = readLicense license - , _comment = maybe Nothing (\ (Field (_, comment)) -> Just comment) (lookupP "Comment" p) } - _ -> Nothing + Just license) -> + Right $ LicenseDescription + { _license = readLicense license + , _comment = fieldValue "Comment" p } + _ -> Left p toControlFile :: CopyrightDescription -> Control' Text toControlFile d = @@ -260,9 +262,6 @@ , _filesLicense = fromCabalLicense license , _filesComment = comment }) licenseComments } -} - -nothingIf :: (a -> Bool) -> a -> Maybe a -nothingIf p x = if p x then Nothing else Just x -- | Replace empty lines with single dots dots :: Text -> Text diff --git a/src/Debian/Debianize/InputCabal.hs b/src/Debian/Debianize/InputCabal.hs --- a/src/Debian/Debianize/InputCabal.hs +++ b/src/Debian/Debianize/InputCabal.hs @@ -9,6 +9,7 @@ import Control.Category ((.)) import Control.Exception (bracket) import Control.Monad (when) +import Control.Monad.Trans (MonadIO, liftIO) import Data.Set as Set (Set, toList) import Debian.Debianize.BasicInfo (Flags, buildEnv, dependOS, verbosity, compilerFlavor, cabalFlagAssignments) import Debian.Debianize.Prelude (intToVerbosity') @@ -35,12 +36,13 @@ import System.Exit (ExitCode(..)) import System.Posix.Files (setFileCreationMask) import System.Process (system) +import System.Unix.Mount (WithProcAndSys) -- | Load a PackageDescription using the information in the Flags record - -- in particular, using the dependency environment in the EnvSet, find -- the newest available compiler of the requested compiler flavor and -- use that information load the configured PackageDescription. -inputCabalization :: Flags -> IO PackageDescription +inputCabalization :: MonadIO m => Flags -> WithProcAndSys m PackageDescription inputCabalization flags = do let root = dependOS $ getL buildEnv flags let vb = intToVerbosity' $ getL verbosity flags @@ -48,7 +50,7 @@ -- Load a GenericPackageDescription from the current directory and -- from that create a finalized PackageDescription for the given -- CompilerId. - genPkgDesc <- defaultPackageDesc vb >>= readPackageDescription vb + genPkgDesc <- liftIO $ defaultPackageDesc vb >>= readPackageDescription vb #if MIN_VERSION_Cabal(1,22,0) cinfo <- getCompilerInfo root (getL compilerFlavor flags) #else @@ -56,10 +58,10 @@ #endif let finalized = finalizePackageDescription (toList fs) (const True) (Platform buildArch Cabal.buildOS) cinfo [] genPkgDesc ePkgDesc <- either (return . Left) - (\ (pkgDesc, _) -> do bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc + (\ (pkgDesc, _) -> do liftIO $ bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> autoreconf vb pkgDesc return (Right pkgDesc)) finalized - either (\ deps -> getCurrentDirectory >>= \ here -> + either (\ deps -> liftIO getCurrentDirectory >>= \ here -> error $ "Missing dependencies in cabal package at " ++ here ++ ": " ++ show deps) return ePkgDesc diff --git a/src/Debian/Debianize/InputDebian.hs b/src/Debian/Debianize/InputDebian.hs --- a/src/Debian/Debianize/InputDebian.hs +++ b/src/Debian/Debianize/InputDebian.hs @@ -226,7 +226,7 @@ (_, ".substvars") -> return () -- Unsupported (_, "") -> return () -- File with no extension (_, x) | last x == '~' -> return () -- backup file - _ -> trace ("Ignored: " ++ debian name) (return ()) + _ -> liftIO (putStrLn $ "Ignored debianization file: " ++ debian name) -- | Read a line from a debian .links file readLink :: Monad m => BinPkgName -> Text -> DebianT m () diff --git a/src/Debian/Debianize/Output.hs b/src/Debian/Debianize/Output.hs --- a/src/Debian/Debianize/Output.hs +++ b/src/Debian/Debianize/Output.hs @@ -89,7 +89,7 @@ do inputDebianization old <- get diff <- liftIO $ compareDebianization old new - liftIO $ putStr ("Debianization (dry run):\n" ++ diff) + liftIO $ putStrLn ("Debianization (dry run):\n" ++ if null diff then " No changes\n" else diff) _ -> writeDebianization where usageHeader progName = diff --git a/src/Debian/GHC.hs b/src/Debian/GHC.hs --- a/src/Debian/GHC.hs +++ b/src/Debian/GHC.hs @@ -18,6 +18,7 @@ import Control.DeepSeq (force) import Control.Exception (SomeException, try) import Control.Monad (when) +import Control.Monad.Trans (MonadIO, liftIO) import Data.Char ({-isSpace, toLower,-} toUpper) import Data.Function.Memoize (deriveMemoizable, memoize2) import Data.Maybe (fromMaybe) @@ -35,6 +36,7 @@ import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcess, showCommandForUser, readProcessWithExitCode) import System.Unix.Chroot (useEnv, fchroot) +import System.Unix.Mount (WithProcAndSys) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) @@ -162,14 +164,12 @@ -- -- Assumes the compiler executable is already installed in the root -- environment. -getCompilerInfo :: FilePath -> CompilerFlavor -> IO CompilerInfo -getCompilerInfo "/" flavor = do -{- - (code, _, _) <- readProcessWithExitCode "apt-get" ["install", compilerDebName] "" - case code of - ExitFailure n -> error $ "Failure " ++ show n ++ " installing compiler flavor " ++ show flavor - _ -> return () --} +getCompilerInfo :: MonadIO m => FilePath -> CompilerFlavor -> WithProcAndSys m CompilerInfo +getCompilerInfo "/" flavor = liftIO $ getCompilerInfo' flavor +getCompilerInfo root flavor = liftIO $ fchroot root $ getCompilerInfo' flavor + +getCompilerInfo' :: CompilerFlavor -> IO CompilerInfo +getCompilerInfo' flavor = do compilerId <- runVersionCommand >>= toCompilerId flavor compilerCompat <- case flavor of GHCJS -> readProcessWithExitCode "ghcjs" ["--numeric-ghc-version"] "" >>= toCompilerId GHC >>= return . Just . (: []) @@ -187,6 +187,4 @@ case filter ((== "\n") . snd) (readP_to_S parseVersion out) of [(v, _)] -> return $ CompilerId flavor' v _ -> error $ "Parse failure for version string: " ++ show out - -getCompilerInfo root flavor = fchroot root $ getCompilerInfo "/" flavor #endif diff --git a/src/OldLens.hs b/src/OldLens.hs --- a/src/OldLens.hs +++ b/src/OldLens.hs @@ -1,3 +1,6 @@ +-- | Temporary wrappers for conversion from data-lens package to lens. +-- Uses of these should eventually be inlined and this module moved +-- elsewhere. {-# LANGUAGE Rank2Types, GADTs #-} module OldLens ( Lens