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.39 +Version: 5.0 Copyright: Copyright (c) 2007-2014, David Fox, Jeremy Shaw; 2017-2019 Clint Adams License: BSD3 License-File: LICENSE @@ -168,7 +168,6 @@ hsemail, HUnit, lens, - memoize >= 0.7, mtl, network-uri, newtype-generics >= 0.4, @@ -177,11 +176,10 @@ process, pureMD5, regex-tdfa, - set-extra, syb, text, unix, - Unixutils >= 1.53, + unliftio >= 0.2.8.0, utf8-string, optparse-applicative >= 0.11, ansi-wl-pprint == 0.6.*, @@ -232,8 +230,7 @@ debian >= 3.95, lens, mtl, - pretty >= 1.1.2, - Unixutils >= 1.53 + pretty >= 1.1.2 Test-Suite cabal-debian-tests Buildable: False diff --git a/src/Debian/Debianize/BuildDependencies.hs b/src/Debian/Debianize/BuildDependencies.hs --- a/src/Debian/Debianize/BuildDependencies.hs +++ b/src/Debian/Debianize/BuildDependencies.hs @@ -10,6 +10,8 @@ import Control.Applicative ((<$>)) #endif import Control.Lens +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (liftIO) import Control.Monad.State (MonadState(get)) import Control.Monad.Trans (MonadIO) import Data.Char (isSpace, toLower) @@ -20,7 +22,7 @@ import Data.Monoid ((<>)) import Data.Set as Set (empty, fold, fromList, map, member, Set, singleton, toList, union) import Debian.Debianize.Prelude -import Debian.Debianize.BasicInfo (buildEnv, compilerFlavor, EnvSet(dependOS)) +import Debian.Debianize.BasicInfo (compilerFlavor) import Debian.Debianize.Bundled (builtIn) import qualified Debian.Debianize.DebInfo as D import Debian.Debianize.DebianName (mkPkgName, mkPkgName') @@ -87,8 +89,7 @@ (mergeCabalDependencies $ concatMap Cabal.targetBuildDepends buildInfos) (mergeCabalDependencies $ mapMaybe convertLegacy $ concatMap buildTools buildInfos) (mergeCabalDependencies $ mapMaybe convertPkgconfig $ concatMap pkgconfigDepends buildInfos) - (concatMap extraLibs buildInfos) >>= - return {- . List.filter (not . selfDependency (Cabal.package pkgDesc)) -} + (concatMap extraLibs buildInfos) where #if MIN_VERSION_Cabal(2,0,0) convertLegacy :: LegacyExeDependency -> Maybe Dependency @@ -108,9 +109,9 @@ [ExtraLibs (fixDeps atoms extraLibs')] fixDeps :: CabalInfo -> [String] -> Relations - fixDeps atoms xs = + fixDeps atoms = concatMap (\ cab -> fromMaybe [[D.Rel (D.BinPkgName ("lib" ++ List.map toLower cab ++ "-dev")) Nothing Nothing]] - (Map.lookup cab (view (A.debInfo . D.extraLibMap) atoms))) xs + (Map.lookup cab (view (A.debInfo . D.extraLibMap) atoms))) -- | Take the intersection of all the dependencies on a given package name mergeCabalDependencies :: [Dependency] -> [Dependency] @@ -156,9 +157,9 @@ bDeps <- use (A.debInfo . D.control . S.buildDepends) compat <- use (A.debInfo . D.compat) - let ghcdev = compilerPackageName hflavor B.Development + ghcdev <- liftIO $ compilerPackageName hflavor B.Development + ghcprof <- liftIO $ compilerPackageName hflavor B.Profiling let ghcrel = if member GHC hcs then maybe [] ((: []) . anyrel') ghcdev else [] - let ghcprof = compilerPackageName hflavor B.Profiling let ghcrelprof = if prof then maybe [] ((: []) . anyrel') ghcprof else [] let xs = nub $ [maybe [] (\ n -> [D.Rel (D.BinPkgName "debhelper") (Just (D.GRE (parseDebianVersion' (show n)))) Nothing]) compat, [D.Rel (D.BinPkgName "haskell-devscripts-minimal") Nothing Nothing, @@ -208,7 +209,7 @@ bDeps <- use (A.debInfo . D.control . S.buildDependsIndep) libDeps <- allBuildDepends (maybe [] (return . libBuildInfo) (Cabal.library pkgDesc)) cDeps <- mapM docDependencies libDeps - let ghcdoc = compilerPackageName hc B.Documentation + ghcdoc <- liftIO $ compilerPackageName hc B.Documentation let hcdocdep = if doc && member GHC hcs then maybe [] ((: []) . anyrel') ghcdoc else [] let xs = nub $ if doc && isJust (Cabal.library pkgDesc) then hcdocdep ++ bDeps ++ concat cDeps @@ -239,7 +240,7 @@ buildDependencies _ dep = case unboxDependency dep of Just (Dependency _name _ranges) -> - do mp <- get >>= return . view (A.debInfo . D.execMap) + do mp <- view (A.debInfo . D.execMap) <$> get return $ concat $ adapt mp dep Nothing -> return [] @@ -304,13 +305,13 @@ case isNoVersion range''' of True -> return Nothing False -> - foldVersionRange' + Just <$> foldVersionRange' (return $ Rel' (D.Rel dname Nothing Nothing)) - (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.EEQ dv)) Nothing)) - (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.SGR dv)) Nothing)) - (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.SLT dv)) Nothing)) - (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.GRE dv)) Nothing)) - (\ v -> debianVersion' name v >>= \ dv -> return $ Rel' (D.Rel dname (Just (D.LTE dv)) Nothing)) + (debianVersion' name >=> \ dv -> return $ Rel' (D.Rel dname (Just (D.EEQ dv)) Nothing)) + (debianVersion' name >=> \ dv -> return $ Rel' (D.Rel dname (Just (D.SGR dv)) Nothing)) + (debianVersion' name >=> \ dv -> return $ Rel' (D.Rel dname (Just (D.SLT dv)) Nothing)) + (debianVersion' name >=> \ dv -> return $ Rel' (D.Rel dname (Just (D.GRE dv)) Nothing)) + (debianVersion' name >=> \ dv -> return $ Rel' (D.Rel dname (Just (D.LTE dv)) Nothing)) #if MIN_VERSION_Cabal(2,0,0) (\ x y -> debianVersion' name x >>= \ dvx -> debianVersion' name y >>= \ dvy -> @@ -324,7 +325,7 @@ (\ x y -> x >>= \ x' -> y >>= \ y' -> return $ Or [x', y']) (\ x y -> x >>= \ x' -> y >>= \ y' -> return $ And [x', y']) id - range''' >>= return . Just + range''' where -- Choose the simpler of the two range''' = canon (simpler range' range'') @@ -367,21 +368,20 @@ -> [D.Relation] -> CabalT m [D.Relation] doBundled typ name hc rels = do - let hcname = compilerPackageName hc typ - mapM (doRel hcname) rels >>= return . concat + hcname <- liftIO $ compilerPackageName hc typ + concat <$> mapM (doRel hcname) rels where -- If a library is built into the compiler, this is the debian -- package name the compiler will conflict with. - doRel :: Monad m => Maybe BinPkgName -> D.Relation -> CabalT m [D.Relation] + doRel :: MonadIO m => Maybe BinPkgName -> D.Relation -> CabalT m [D.Relation] doRel hcname rel@(D.Rel dname req _) = do let comp = maybe [] (\x -> [D.Rel x Nothing Nothing]) hcname -- gver <- use ghcVersion - root <- use (A.debInfo . D.flags . buildEnv) >>= return . dependOS -- Look at what version of the package is provided by the compiler. atoms <- get -- What version of this package (if any) does the compiler provide? - let relInfo = builtIn hc root - pver = listToMaybe $ fmap (debianVersion'' atoms) (filter ((== name) . pkgName) relInfo) + relInfo <- liftIO $ builtIn hc + let pver = listToMaybe $ fmap (debianVersion'' atoms) (filter ((== name) . pkgName) relInfo) -- The name this library would have if it was in the compiler conflicts list. let naiveDebianName = mkPkgName hc name typ -- The compiler should appear in the build dependency @@ -423,7 +423,7 @@ canonical :: Rels a -> Rels a canonical (Rel' rel) = And [Or [Rel' rel]] canonical (And rels) = And $ concatMap (unAnd . canonical) rels -canonical (Or rels) = And . List.map Or $ sequence $ List.map (concat . List.map unOr . unAnd . canonical) $ rels +canonical (Or rels) = And . List.map Or $ mapM (concatMap unOr . unAnd . canonical) rels filterMissing :: Monad m => [[Relation]] -> CabalT m [[Relation]] filterMissing rels = diff --git a/src/Debian/Debianize/Bundled.hs b/src/Debian/Debianize/Bundled.hs --- a/src/Debian/Debianize/Bundled.hs +++ b/src/Debian/Debianize/Bundled.hs @@ -1,12 +1,12 @@ -- | Determine whether a specific version of a Haskell package is -- bundled with into this particular version of the given compiler. -- This is done by getting the "Provides" field from the output of --- "apt-cache showpkg ghc" (run in the appropriate changeroot) and +-- "apt-cache showpkg ghc" and -- converting the debian package names back to Cabal package names. -- *That* is done using the debianNameMap of CabalInfo, which is -- built using the mapCabal, splitCabal, and remapCabal functions. -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} +{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} module Debian.Debianize.Bundled ( builtIn -- * Utilities @@ -23,12 +23,9 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif -import Control.DeepSeq (force, NFData) import Control.Exception (SomeException, try) -import Control.Monad.Catch (MonadMask) -import Control.Monad.Trans (MonadIO) +import Control.Monad ((<=<)) import Data.Char (isAlphaNum, toLower) -import Data.Function.Memoize (memoize2, memoize3) import Data.List (groupBy, intercalate, isPrefixOf, stripPrefix) import Data.Maybe (listToMaybe, mapMaybe) import Data.Set as Set (difference, fromList) @@ -49,12 +46,11 @@ #else import Distribution.Compiler (CompilerFlavor) #endif -import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcess, showCommandForUser) -import System.Unix.Chroot (useEnv) import Test.HUnit (assertEqual, Test(TestList, TestCase)) import Text.ParserCombinators.ReadP (char, endBy1, munch1, ReadP, readP_to_S) import Text.Regex.TDFA ((=~)) +import UnliftIO.Memoize (memoizeMVar, Memoized, runMemoized) #if MIN_VERSION_base(4,8,0) #if !MIN_VERSION_Cabal(2,0,0) @@ -78,10 +74,11 @@ -- This is done by looking for .conf files beneath a package.conf.d -- directory and parsing the name. (Probably better to actually read -- the .conf file.) -builtIn :: CompilerFlavor -> FilePath -> [PackageIdentifier] -builtIn hc root = - let Just hcname = (hcExecutablePath root hc >>= hcBinPkgName root) in - aptCacheProvides hcname root +builtIn :: CompilerFlavor -> IO [PackageIdentifier] +builtIn hc = do + Just hep <- hcExecutablePath hc >>= runMemoized + Just hcname <- hcBinPkgName hep >>= runMemoized + runMemoized =<< aptCacheProvides hcname -- | Convert CompilerFlavor to an executable name in a way that works -- for at least the cases we are interested in. This might need to be @@ -90,95 +87,76 @@ hcExecutable = map toLower . show -- | Use which(1) to determine full path name to haskell compiler executable -hcExecutablePath :: FilePath -> CompilerFlavor -> Maybe FilePath -hcExecutablePath = memoize2 $ \root hc -> - listToMaybe $ lines $ unsafePerformIO $ chroot root (readProcess "which" [hcExecutable hc] "") +hcExecutablePath :: CompilerFlavor -> IO (Memoized (Maybe FilePath)) +hcExecutablePath hc = memoizeMVar (listToMaybe . lines <$> readProcess "which" [hcExecutable hc] "") -hcVersion :: FilePath -> CompilerFlavor -> Maybe Version -hcVersion root hc = - let Just hcpath = hcExecutablePath root hc in - maybe Nothing parseVersion' $ - listToMaybe $ - lines $ - unsafePerformIO . chroot root $ - readProcess hcpath +hcVersion :: CompilerFlavor -> IO (Maybe Version) +hcVersion hc = do + Just hcpath <- runMemoized =<< hcExecutablePath hc + ver <- readProcess hcpath [case hc of #if MIN_VERSION_Cabal(1,22,0) GHCJS -> "--numeric-ghc-version" #endif _ -> "--numeric-version"] "" + return $ maybe Nothing parseVersion' (listToMaybe (lines ver)) -- | Use dpkg -S to convert the executable path to a debian binary -- package name. -hcBinPkgName :: FilePath -> FilePath -> Maybe BinPkgName -hcBinPkgName = memoize2 $ \root path -> - let s = unsafePerformIO (chroot root (readProcess "dpkg" ["-S", path] "")) in - case map (takeWhile (/= ':')) (lines s) of +hcBinPkgName :: FilePath -> IO (Memoized (Maybe BinPkgName)) +hcBinPkgName path = memoizeMVar $ do + s <- readProcess "dpkg" ["-S", path] "" + return $ case map (takeWhile (/= ':')) (lines s) of [] -> Nothing [name] -> Just (BinPkgName name) _ -> error $ "Unexpected output from " ++ showCommandForUser "dpkg" ["-S", path] ++ ": ++ " ++ show s -- | What built in libraries does this haskell compiler provide? -aptCacheProvides :: BinPkgName -> FilePath -> [PackageIdentifier] -aptCacheProvides = memoize2 aptCacheProvides' - where - aptCacheProvides' hcname root = - {-trace ("aptCacheProvides " ++ show hcname ++ " in " ++ root ++ " -> " ++ show pis)-} - packageIdentifiers root hcname +aptCacheProvides :: BinPkgName -> IO (Memoized [PackageIdentifier]) +aptCacheProvides = memoizeMVar . packageIdentifiers -packageIdentifiers :: String -> BinPkgName -> [PackageIdentifier] -packageIdentifiers root hcname = - (mapMaybe parsePackageIdentifier' . - mapMaybe (dropRequiredSuffix ".conf") . - map last . - filter (elem "package.conf.d") . - map (groupBy (\a b -> (a == '/') == (b == '/')))) (binPkgFiles root hcname) +packageIdentifiers :: BinPkgName -> IO [PackageIdentifier] +packageIdentifiers hcname = + mapMaybe parsePackageIdentifier' . + mapMaybe (dropRequiredSuffix ".conf" . last) . + filter (elem "package.conf.d") . + map (groupBy (\a b -> (a == '/') == (b == '/'))) <$> binPkgFiles hcname dropRequiredSuffix :: String -> String -> Maybe String dropRequiredSuffix suff x = let (x', suff') = splitAt (length x - length suff) x in if suff == suff' then Just x' else Nothing -- | A list of the files in a binary deb -binPkgFiles :: String -> BinPkgName -> [FilePath] -binPkgFiles root hcname = lines $ unsafePerformIO (chroot root (readProcess "dpkg" ["-L", unBinPkgName hcname] "")) - -{- -takeBetween :: (a -> Bool) -> (a -> Bool) -> [a] -> [a] -takeBetween startPred endPred = takeWhile (not . endPred) . dropWhile startPred . dropWhile (not . startPred) --} +binPkgFiles :: BinPkgName -> IO [FilePath] +binPkgFiles hcname = lines <$> readProcess "dpkg" ["-L", unBinPkgName hcname] "" -aptCacheConflicts :: FilePath -> String -> DebianVersion -> [BinPkgName] -aptCacheConflicts root hcname ver = - either (\ _ -> []) (mapMaybe doLine . lines) (aptCacheDepends root hcname (show (prettyDebianVersion ver))) +aptCacheConflicts :: String -> DebianVersion -> IO [BinPkgName] +aptCacheConflicts hcname ver = + either (const []) (mapMaybe doLine . lines) <$> (runMemoized =<< aptCacheDepends hcname (show (prettyDebianVersion ver))) where doLine s = case s =~ "^[ ]*Conflicts:[ ]*<(.*)>$" :: (String, String, String, [String]) of (_, _, _, [name]) -> Just (BinPkgName name) _ -> Nothing -aptCacheDepends :: FilePath -> String -> String -> Either SomeException String -aptCacheDepends = - memoize3 (\ root hcname ver -> unsafePerformIO (try (chroot root (readProcess "apt-cache" ["depends", hcname ++ "=" ++ ver] "")))) - -aptVersions :: FilePath -> BinPkgName -> [DebianVersion] -aptVersions root hcname = - either (\ _ -> []) (map parseDebianVersion' . filter (/= "") . map (takeWhile (/= ' ')) . takeWhile (not . isPrefixOf "Reverse Depends:") . drop 1 . dropWhile (not . isPrefixOf "Versions:") . lines) (aptCacheShowPkg root hcname) - -aptCacheShowPkg :: FilePath -> BinPkgName -> Either SomeException String -aptCacheShowPkg = - memoize2 (\ root hcname -> unsafePerformIO (try (chroot root (readProcess "apt-cache" ["showpkg", unBinPkgName hcname] "")))) +aptCacheDepends :: String -> String -> IO (Memoized (Either SomeException String)) +aptCacheDepends hcname ver = + memoizeMVar (try (readProcess "apt-cache" ["depends", hcname ++ "=" ++ ver] "")) +aptVersions :: BinPkgName -> IO [DebianVersion] +aptVersions = + return . either (const []) (map parseDebianVersion' . filter (/= "") . map (takeWhile (/= ' ')) . takeWhile (not . isPrefixOf "Reverse Depends:") . drop 1 . dropWhile (not . isPrefixOf "Versions:") . lines) <=< (runMemoized <=< aptCacheShowPkg) -chroot :: (NFData a, MonadIO m, MonadMask m) => String -> m a -> m a -chroot "/" = id -chroot root = useEnv root (return . force) +aptCacheShowPkg :: BinPkgName -> IO (Memoized (Either SomeException String)) +aptCacheShowPkg hcname = + memoizeMVar (try (readProcess "apt-cache" ["showpkg", unBinPkgName hcname] "")) -- | A package identifier is a package name followed by a dash and -- then a version number. A package name, according to the cabal -- users guide "can use letters, numbers and hyphens, but not spaces." -- So be it. parsePackageIdentifier :: ReadP PackageIdentifier -parsePackageIdentifier = do +parsePackageIdentifier = #if MIN_VERSION_Cabal(2,0,0) makeId <$> ((,) <$> endBy1 (munch1 isAlphaNum) (char '-') <*> parseCabalVersion) where @@ -219,16 +197,16 @@ Nothing (parseMaybe parsePackageIdentifier "HUnit-1.2.3 ")) , TestCase $ do - ghc <- (head . lines) <$> readProcess "which" ["ghc"] "" + ghc <- head . lines <$> readProcess "which" ["ghc"] "" let ver = fmap (takeWhile (/= '/')) (stripPrefix "/opt/ghc/" ghc) - let expected = - (Set.fromList + acp <- runMemoized =<< aptCacheProvides (BinPkgName ("ghc" ++ maybe "" ("-" ++) ver)) + let expected = Set.fromList -- This is the package list for ghc-7.10.3 ["array", "base", "binary", "bin-package-db", "bytestring", "Cabal", "containers", "deepseq", "directory", "filepath", "ghc", "ghc-prim", "haskeline", "hoopl", "hpc", "integer-gmp", "pretty", "process", - "template-haskell", "terminfo", "time", "transformers", "unix", "xhtml"]) - actual = Set.fromList (map (unPackageName . pkgName) (aptCacheProvides (BinPkgName ("ghc" ++ maybe "" ("-" ++) ver)) "/")) + "template-haskell", "terminfo", "time", "transformers", "unix", "xhtml"] + actual = Set.fromList (map (unPackageName . pkgName) acp) missing (Just "8.0.1") = Set.fromList ["bin-package-db"] missing (Just "8.0.2") = Set.fromList ["bin-package-db"] missing _ = mempty 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 @@ -38,7 +38,6 @@ import Distribution.Package (PackageName) import Distribution.PackageDescription as Cabal (PackageDescription(homepage)) import Prelude hiding (init, init, log, log, null) -import System.Unix.Mount (withProcAndSys) -- | Bits and pieces of information about the mapping from cabal package -- names and versions to debian package names and versions. In essence, @@ -77,7 +76,7 @@ -- 'CabalInfo' record. newCabalInfo :: (MonadIO m, MonadMask m{-, Functor m-}) => Flags -> m (Either String CabalInfo) newCabalInfo flags' = - withProcAndSys "/" $ inputCabalization flags' >>= either (return . Left) (\p -> Right <$> doPkgDesc p) + inputCabalization flags' >>= either (return . Left) (\p -> Right <$> doPkgDesc p) where doPkgDesc pkgDesc = do copyrt <- liftIO $ defaultCopyrightDescription pkgDesc diff --git a/src/Debian/Debianize/Finalize.hs b/src/Debian/Debianize/Finalize.hs --- a/src/Debian/Debianize/Finalize.hs +++ b/src/Debian/Debianize/Finalize.hs @@ -28,7 +28,6 @@ import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Monoid ((<>)) import Data.Set as Set (difference, filter, fold, fromList, insert, map, null, Set, singleton, toList, union, unions) -import Data.Set.Extra as Set (mapM_) import Data.Text as Text (intercalate, pack, Text, unlines, unpack) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) import Debian.Codename (parseCodename) @@ -530,8 +529,7 @@ B.breaks .= [] B.builtUsing .= [] - unless (typ == B.Documentation) $ do - B.provides %= (anyrel "${haskell:Provides}" :) + unless (typ == B.Documentation) $ B.provides %= (anyrel "${haskell:Provides}" :) -- | Add the library paragraphs for a particular compiler flavor. librarySpecs :: (Monad m) => PackageDescription -> CompilerFlavor -> CabalT m () @@ -641,13 +639,13 @@ (A.debInfo . D.binaryDebDescription b . B.binarySection) .?= Just (MainSection "misc") binaryPackageRelations b B.Utilities -- Add the unassigned files to the utils packages - Set.mapM_ (\ (foo, bar) -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing - Set.mapM_ (\ name -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec b name "usr/bin")) utilsExecMissing + mapM_ (\ (foo, bar) -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing + mapM_ (\ name -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec b name "usr/bin")) utilsExecMissing where ename i = case D.sourceDir i of - (Nothing) -> D.execName i - (Just s) -> s D.execName i + Nothing -> D.execName i + Just s -> s D.execName i expandAtoms :: Monad m => CabalT m () -> CabalT m () expandAtoms goodies = @@ -694,7 +692,7 @@ expandInstallCabalExecs :: Monad m => FilePath -> CabalT m () expandInstallCabalExecs builddir = do hc <- use (A.debInfo . D.flags . compilerFlavor) - use (A.debInfo . D.atomSet) >>= Set.mapM_ (doAtom hc) + use (A.debInfo . D.atomSet) >>= mapM_ (doAtom hc) where doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m () doAtom GHC (D.InstallCabalExec b name dest) = (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b (builddir name name) dest) @@ -714,7 +712,7 @@ expandInstallCabalExecTo :: Monad m => FilePath -> CabalT m () expandInstallCabalExecTo builddir = do hc <- use (A.debInfo . D.flags . compilerFlavor) - use (A.debInfo . D.atomSet) >>= Set.mapM_ (doAtom hc) + use (A.debInfo . D.atomSet) >>= mapM_ (doAtom hc) where doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m () doAtom GHC (D.InstallCabalExecTo b name dest) = @@ -774,11 +772,12 @@ finalizeRules = do DebBase b <- debianNameBase hc <- use (A.debInfo . D.flags . compilerFlavor) - let BinPkgName hcdeb = maybe (error "No compiler package") id (compilerPackageName hc B.Development) + cpn <- liftIO $ compilerPackageName hc B.Development + let BinPkgName hcdeb = fromMaybe (error "No compiler package") cpn (A.debInfo . D.rulesHead) .?= Just "#!/usr/bin/make -f" (A.debInfo . D.rulesSettings) %= (++ ["DEB_CABAL_PACKAGE = " <> pack b]) (A.debInfo . D.rulesSettings) %= (++ ["DEB_DEFAULT_COMPILER = " <> pack hcdeb]) - flags <- (flagString . Set.toList) <$> use (A.debInfo . D.flags . cabalFlagAssignments) + flags <- flagString . Set.toList <$> use (A.debInfo . D.flags . cabalFlagAssignments) unless (List.null flags) ((A.debInfo . D.rulesSettings) %= (++ ["DEB_SETUP_GHC_CONFIGURE_ARGS = " <> pack flags])) (A.debInfo . D.rulesIncludes) %= (++ ["include /usr/share/cdbs/1/rules/debhelper.mk", "include /usr/share/cdbs/1/class/hlibrary.mk"]) @@ -809,7 +808,7 @@ flagString :: [(FlagName, Bool)] -> String #if MIN_VERSION_Cabal(2,0,0) -flagString = List.intercalate " " . List.map (\ (s, sense) -> "-f" ++ (if sense then "" else "-") ++ unFlagName s) +flagString = unwords . List.map (\ (s, sense) -> "-f" ++ (if sense then "" else "-") ++ unFlagName s) #else -flagString = List.intercalate " " . List.map (\ (FlagName s, sense) -> "-f" ++ (if sense then "" else "-") ++ s) +flagString = unwords . List.map (\ (FlagName s, sense) -> "-f" ++ (if sense then "" else "-") ++ s) #endif 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 @@ -12,7 +12,7 @@ import Control.Applicative ((<$>)) #endif import Data.Set as Set (toList) -import Debian.Debianize.BasicInfo (Flags, buildEnv, dependOS, verbosity, compilerFlavor, cabalFlagAssignments) +import Debian.Debianize.BasicInfo (Flags, verbosity, compilerFlavor, cabalFlagAssignments) import Debian.Debianize.Prelude (intToVerbosity') #if MIN_VERSION_Cabal(1,22,0) import Debian.GHC (getCompilerInfo) @@ -51,7 +51,6 @@ import System.Exit (ExitCode(..)) import System.Posix.Files (setFileCreationMask) import System.Process (system) -import System.Unix.Mount (WithProcAndSys) #if !MIN_VERSION_Cabal(1,22,0) type CompilerInfo = CompilerId @@ -61,11 +60,11 @@ -- 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 :: forall m. (MonadIO m) => Flags -> WithProcAndSys m (Either String PackageDescription) +inputCabalization :: forall m. (MonadIO m) => Flags -> m (Either String PackageDescription) inputCabalization flags = getCompInfo flags >>= either (return . Left) (\cinfo -> Right <$> doCompInfo cinfo) where - doCompInfo :: CompilerInfo -> WithProcAndSys m PackageDescription + doCompInfo :: CompilerInfo -> m PackageDescription doCompInfo cinfo = do -- Load a GenericPackageDescription from the current directory -- and from that create a finalized PackageDescription for the @@ -91,15 +90,13 @@ vb = intToVerbosity' $ view verbosity flags fs = view cabalFlagAssignments flags -getCompInfo :: MonadIO m => Flags -> WithProcAndSys m (Either String CompilerInfo) +getCompInfo :: MonadIO m => Flags -> m (Either String CompilerInfo) getCompInfo flags = #if MIN_VERSION_Cabal(1,22,0) - getCompilerInfo root (view compilerFlavor flags) + getCompilerInfo (view compilerFlavor flags) #else - return $ newestAvailableCompilerId root (view compilerFlavor flags) + return $ newestAvailableCompilerId (view compilerFlavor flags) #endif - where - root = dependOS $ view buildEnv flags -- | Run the package's configuration script. autoreconf :: Verbosity -> Cabal.PackageDescription -> IO () diff --git a/src/Debian/GHC.hs b/src/Debian/GHC.hs --- a/src/Debian/GHC.hs +++ b/src/Debian/GHC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Debian.GHC ( withCompilerVersion @@ -9,11 +9,6 @@ -- , ghcNewestAvailableVersion' -- , ghcNewestAvailableVersion -- , compilerIdFromDebianVersion - , hvrCabalVersion - , hvrHappyVersion - , hvrAlexVersion - , hvrCompilerPATH - , isHVRCompilerPackage , withModifiedPATH -- , CompilerChoice(..), hcVendor, hcFlavor , compilerPackageName @@ -25,13 +20,12 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.DeepSeq (force) import Control.Exception (SomeException, throw, try) import Control.Lens (_2, over) +import Control.Monad ((<=<)) import Control.Monad.Trans (MonadIO, liftIO) import Data.Char (isSpace, toLower, toUpper) -import Data.Function.Memoize (deriveMemoizable, Memoizable, memoize, memoize2, memoizeFinite) -import Data.List (intercalate, isPrefixOf) +import Data.List (intercalate) import Debian.Debianize.BinaryDebDescription (PackageType(..)) import Debian.Relation (BinPkgName(BinPkgName)) import Debian.Version (DebianVersion, parseDebianVersion') @@ -43,53 +37,20 @@ import Distribution.Pretty (prettyShow) import Distribution.Version (mkVersion', mkVersion, Version, versionNumbers) import Data.Version (parseVersion) -import Data.Word (Word64) #else -import Data.Function.Memoize (deriveMemoizable, memoize, memoize2) import Data.Version (showVersion, Version(..), parseVersion) #endif import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..)) -import System.Directory (doesDirectoryExist) import System.Environment (getEnv) import System.Exit (ExitCode(ExitFailure, ExitSuccess)) -- import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) -import System.IO.Unsafe (unsafePerformIO) import System.Process (readProcess, showCommandForUser, readProcessWithExitCode) import System.Posix.Env (setEnv) -import System.Unix.Chroot (useEnv, fchroot) -import System.Unix.Mount (WithProcAndSys) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) import Text.Regex.TDFA ((=~)) - -#if MIN_VERSION_Cabal(2,0,0) -instance Memoizable Word64 where memoize = memoizeFinite -#endif -$(deriveMemoizable ''CompilerFlavor) -$(deriveMemoizable ''Version) -$(deriveMemoizable ''BinPkgName) - --- | Up until now cabal-debian only worked with Debian's or Ubuntu's --- ghc debs, which have binary package names ghc, ghc-prof, ghc-doc, --- etc. This type is intended to add support for Herbert Valerio --- Riedel's (hvr's) repository of several different versions of ghc --- and supporting tools happy, alex and cabal. These have different --- binary package names, and the packages put the executables in --- different locations than the Debian (and Ubuntu) packages. This --- option is activated when a directory such as /opt/ghc/8.0.1/bin is --- present in $PATH and a ghc executable is found there. --- --- This function decides whether a deb name is that of one of --- debian/ubuntu's ghc packages or one of hvr's. If it is an hvr --- package it returns the version number embedded in its name. -isHVRCompilerPackage :: CompilerFlavor -> BinPkgName -> Maybe Version -isHVRCompilerPackage hc (BinPkgName name) = - case isPrefixOf prefix name of - True -> toVersion (takeWhile (/= '-') (drop (length prefix) name)) - False -> Nothing - where - prefix = map toLower (show hc) ++ "-" +import UnliftIO.Memoize (memoizeMVar, runMemoized, Memoized) toVersion :: String -> Maybe Version toVersion s = case filter (all isSpace . snd) (readP_to_S parseVersion s) of @@ -100,56 +61,8 @@ #endif _ -> Nothing -withCompilerVersion :: FilePath -> CompilerFlavor -> (DebianVersion -> a) -> Either String a -withCompilerVersion root hc f = either Left (\v -> Right (f v)) (newestAvailableCompiler root hc) - --- | Return the a string containing the PATH environment variable value --- suitable for using some version of ghc from hvr's compiler repo. -hvrCompilerPATH :: Version -> String -> String -hvrCompilerPATH v path0 = - intercalate ":" ["/opt/ghc/" ++ prettyShow v ++ "/bin", - "/opt/cabal/" ++ prettyShow (hvrCabalVersion v) ++ "/bin", - "/opt/happy/" ++ prettyShow (hvrHappyVersion v) ++ "/bin", - "/opt/alex/" ++ prettyShow (hvrAlexVersion v) ++ "/bin", - path0] - --- | What version of Cabal goes with this version of GHC? -hvrCabalVersion :: Version -> Version -#if MIN_VERSION_Cabal(2,0,0) -hvrCabalVersion v = - case versionNumbers v of - (m : n : _) | (m == 7 && n <= 7) || m < 7 -> mkVersion [1,16] - (7 : n : _) | n <= 9 -> mkVersion [1,18] - (7 : _) -> mkVersion [1,22] - _ -> mkVersion [1,24] -#else -hvrCabalVersion (Version (m : n : _) _) | (m == 7 && n <= 7) || m < 7 = Version [1,16] [] -hvrCabalVersion (Version (7 : n : _) _) | n <= 9 = Version [1,18] [] -hvrCabalVersion (Version (7 : _) _) = Version [1,22] [] -hvrCabalVersion _ = Version [1,24] [] -#endif - --- | What version of Happy goes with this version of GHC? -hvrHappyVersion :: Version -> Version -#if MIN_VERSION_Cabal(2,0,0) -hvrHappyVersion v = - case versionNumbers v of - (m : n : _) | (m == 7 && n <= 3) || m < 7 -> mkVersion [1,19,3] - (7 : n : _) | n <= 2 -> mkVersion [1,19,3] - _ -> mkVersion [1,19,5] -#else -hvrHappyVersion (Version (m : n : _) _) | (m == 7 && n <= 3) || m < 7 = Version [1,19,3] [] -hvrHappyVersion (Version (7 : n : _) _) | n <= 2 = Version [1,19,3] [] -hvrHappyVersion _ = Version [1,19,5] [] -#endif - --- | What version of Alex goes with this version of GHC? -hvrAlexVersion :: Version -> Version -#if MIN_VERSION_Cabal(2,0,0) -hvrAlexVersion _ = mkVersion [3,1,7] -#else -hvrAlexVersion _ = Version [3,1,7] [] -#endif +withCompilerVersion :: CompilerFlavor -> (DebianVersion -> a) -> IO (Either String a) +withCompilerVersion hc f = newestAvailableCompiler hc >>= \nac -> return (fmap f nac) withModifiedPATH :: MonadIO m => (String -> String) -> m a -> m a withModifiedPATH f action = do @@ -163,68 +76,52 @@ return r -- | Memoized version of newestAvailable' -newestAvailable :: FilePath -> BinPkgName -> Either String DebianVersion -newestAvailable root pkg = - memoize2 f pkg root +newestAvailable :: BinPkgName -> IO (Memoized (Either String DebianVersion)) +newestAvailable pkg = memoizeMVar (f pkg) where - f :: BinPkgName -> FilePath -> Either String DebianVersion - f pkg' root' = unsafePerformIO (newestAvailable' root' pkg') + f :: BinPkgName -> IO (Either String DebianVersion) + f = newestAvailable' --- | Look up the newest version of a deb available in the given changeroot. -newestAvailable' :: FilePath -> BinPkgName -> IO (Either String DebianVersion) -newestAvailable' root (BinPkgName name) = do - exists <- doesDirectoryExist root - case exists of - False -> return $ Left $ "newestAvailable: no such environment: " ++ show root - True -> do - versions <- try $ chroot root $ - (readProcess "apt-cache" ["showpkg", name] "" >>= - return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String]) +-- | Look up the newest version of a deb available +newestAvailable' :: BinPkgName -> IO (Either String DebianVersion) +newestAvailable' (BinPkgName name) = do + versions <- try $ dropWhile (/= "Versions: ") . lines <$> readProcess "apt-cache" ["showpkg", name] "" :: IO (Either SomeException [String]) case versions of - Left e -> return $ Left $ "newestAvailable failed in " ++ show root ++ ": " ++ show e + Left e -> return $ Left $ "newestAvailable failed: " ++ show e Right (_ : versionLine : _) -> return . Right . parseDebianVersion' . takeWhile (/= ' ') $ versionLine Right x -> return $ Left $ "Unexpected result from apt-cache showpkg: " ++ show x - where - chroot "/" = id - chroot _ = useEnv root (return . force) -newestAvailableCompiler :: FilePath -> CompilerFlavor -> Either String DebianVersion -newestAvailableCompiler root hc = maybe (Left "No compiler package") (newestAvailable root) (compilerPackageName hc Development) +newestAvailableCompiler :: CompilerFlavor -> IO (Either String DebianVersion) +newestAvailableCompiler hc = maybe (return (Left "No compiler package")) (runMemoized <=< newestAvailable) =<< compilerPackageName hc Development -newestAvailableCompilerId :: FilePath -> CompilerFlavor -> Either String CompilerId -newestAvailableCompilerId root hc = either Left (Right . compilerIdFromDebianVersion hc) (newestAvailableCompiler root hc) +newestAvailableCompilerId :: CompilerFlavor -> IO (Either String CompilerId) +newestAvailableCompilerId hc = fmap (compilerIdFromDebianVersion hc) <$> newestAvailableCompiler hc {- -- | The IO portion of ghcVersion. For there to be no version of ghc -- available is an exceptional condition, it has been standard in -- Debian and Ubuntu for a long time. -ghcNewestAvailableVersion :: CompilerFlavor -> FilePath -> IO DebianVersion -ghcNewestAvailableVersion hc root = do - exists <- doesDirectoryExist root - when (not exists) (error $ "ghcVersion: no such environment: " ++ show root) +ghcNewestAvailableVersion :: CompilerFlavor -> IO DebianVersion +ghcNewestAvailableVersion hc = do versions <- try $ chroot $ (readProcess "apt-cache" ["showpkg", map toLower (show hc)] "" >>= return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String]) case versions of - Left e -> error $ "ghcNewestAvailableVersion failed in " ++ show root ++ ": " ++ show e + Left e -> error $ "ghcNewestAvailableVersion failed in: " ++ show e Right (_ : versionLine : _) -> return . parseDebianVersion . takeWhile (/= ' ') $ versionLine - _ -> error $ "No version of ghc available in " ++ show root - where - chroot = case root of - "/" -> id - _ -> useEnv root (return . force) + _ -> error $ "No version of ghc available" -- | Memoize the CompilerId built for the newest available version of -- the compiler package so we don't keep running apt-cache showpkg -- over and over. -ghcNewestAvailableVersion' :: CompilerFlavor -> FilePath -> CompilerId -ghcNewestAvailableVersion' hc root = - memoize f (hc, root) +ghcNewestAvailableVersion' :: CompilerFlavor -> CompilerId +ghcNewestAvailableVersion' hc = + memoize f hc where f :: (CompilerFlavor, FilePath) -> CompilerId - f (hc', root) = unsafePerformIO (g hc' root) - g hc root = do - ver <- ghcNewestAvailableVersion hc root + f hc' = unsafePerformIO (g hc') + g hc = do + ver <- ghcNewestAvailableVersion hc let cid = compilerIdFromDebianVersion ver -- hPutStrLn stderr ("GHC Debian version: " ++ show ver ++ ", Compiler ID: " ++ show cid) return cid @@ -266,9 +163,10 @@ -- | Compute the compiler package names by finding out what package -- contains the corresponding executable. -compilerPackageName :: CompilerFlavor -> PackageType -> Maybe BinPkgName -compilerPackageName hc typ = - maybe Nothing (Just . finish) (compilerPackage hc) +compilerPackageName :: CompilerFlavor -> PackageType -> IO (Maybe BinPkgName) +compilerPackageName hc typ = do + mcp <- compilerPackage hc + return $ fmap finish mcp where finish (BinPkgName hcname) = let isDebian = map toLower (show hc) == hcname in @@ -286,27 +184,18 @@ (GHC, Profiling, _) -> BinPkgName (hcname ++ "-prof") _ -> BinPkgName hcname -compilerPackage :: CompilerFlavor -> Maybe BinPkgName -compilerPackage GHC = filePackage "ghc" +compilerPackage :: CompilerFlavor -> IO (Maybe BinPkgName) +compilerPackage GHC = filePackage "ghc" >>= runMemoized #if MIN_VERSION_Cabal(1,22,0) -compilerPackage GHCJS = filePackage "ghcjs" +compilerPackage GHCJS = filePackage "ghcjs" >>= runMemoized #endif compilerPackage x = error $ "compilerPackage - unsupported CompilerFlavor: " ++ show x -{- -compilerExecutable :: CompilerFlavor -> String -compilerExecutable GHC = "ghc" -#if MIN_VERSION_Cabal(1,22,0) -compilerExecutable GHCJS = "ghcjs" -#endif -compilerExecutable x = error $ "compilerExecutable - unexpected flavor: " ++ show x --} - -filePackage :: FilePath -> Maybe BinPkgName -filePackage = memoize f +filePackage :: FilePath -> IO (Memoized (Maybe BinPkgName)) +filePackage = memoizeMVar . f where - f :: FilePath -> Maybe BinPkgName - f p = unsafePerformIO (which p >>= maybe (return Nothing) (\x -> package <$> readProcess "dpkg-query" ["-S", x] "")) + f :: FilePath -> IO (Maybe BinPkgName) + f p = which p >>= maybe (return Nothing) (\x -> package <$> readProcess "dpkg-query" ["-S", x] "") package :: String -> Maybe BinPkgName package s = case s =~ "^(.*): .*$" :: (String, String, String, [String]) of @@ -314,8 +203,7 @@ _ -> Nothing which :: String -> IO (Maybe FilePath) -which bin = do - (toPath . over _2 lines) <$> readProcessWithExitCode "which" [bin] "" +which bin = toPath . over _2 lines <$> readProcessWithExitCode "which" [bin] "" where toPath :: (ExitCode, [String], String) -> Maybe String toPath (ExitSuccess, [path], _) = Just path @@ -326,9 +214,8 @@ -- compiler into the chroot if necessary and ask it for its version -- number. This has the benefit of working for ghcjs, which doesn't -- make the base ghc version available in the version number. -getCompilerInfo :: MonadIO m => FilePath -> CompilerFlavor -> WithProcAndSys m (Either String CompilerInfo) -getCompilerInfo "/" flavor = liftIO $ getCompilerInfo' flavor -getCompilerInfo root flavor = liftIO $ fchroot root $ getCompilerInfo' flavor +getCompilerInfo :: MonadIO m => CompilerFlavor -> m (Either String CompilerInfo) +getCompilerInfo flavor = liftIO $ getCompilerInfo' flavor getCompilerInfo' :: CompilerFlavor -> IO (Either String CompilerInfo) getCompilerInfo' flavor = do