-- | 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" 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 FlexibleContexts, ScopedTypeVariables #-}
module Debian.Debianize.Bundled
    ( builtIn
    -- * Utilities
    , aptCacheShowPkg
    , aptCacheProvides
    , aptCacheDepends
    , aptCacheConflicts
    , aptVersions
    , hcVersion
    , parseVersion'
    , tests
    ) where

import Control.Exception (SomeException, try)
import Control.Monad ((<=<))
import Data.Char (isAlphaNum, toLower)
import Data.List (groupBy, intercalate, isPrefixOf, stripPrefix)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Set as Set (difference, fromList)
import Debian.GHC ({-instance Memoizable CompilerFlavor-})
import Debian.Relation (BinPkgName(..))
import Debian.Relation.ByteString ()
import Debian.Version (DebianVersion, parseDebianVersion', prettyDebianVersion)
import Distribution.Package (mkPackageName, PackageIdentifier(..), unPackageName)
import Data.Version (parseVersion)
import Distribution.Version(mkVersion, mkVersion', Version)
import Distribution.Simple.Compiler (CompilerFlavor(GHCJS))
import System.Process (readProcess, showCommandForUser)
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)

-- | Find out what version, if any, of a cabal library is built into
-- the newest version of haskell compiler hc in environment root.
-- 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 -> IO [PackageIdentifier]
builtIn :: CompilerFlavor -> IO [PackageIdentifier]
builtIn CompilerFlavor
hc = do
  Just String
hep <- CompilerFlavor -> IO (Memoized (Maybe String))
hcExecutablePath CompilerFlavor
hc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized
  Just BinPkgName
hcname <- String -> IO (Memoized (Maybe BinPkgName))
hcBinPkgName String
hep forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized
  forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BinPkgName -> IO (Memoized [PackageIdentifier])
aptCacheProvides BinPkgName
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
-- fudged or replaced as more cases become interesting.
hcExecutable :: CompilerFlavor -> String
hcExecutable :: CompilerFlavor -> String
hcExecutable = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Use which(1) to determine full path name to haskell compiler executable
hcExecutablePath :: CompilerFlavor -> IO (Memoized (Maybe FilePath))
hcExecutablePath :: CompilerFlavor -> IO (Memoized (Maybe String))
hcExecutablePath CompilerFlavor
hc = forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"which" [CompilerFlavor -> String
hcExecutable CompilerFlavor
hc] String
"")

hcVersion :: CompilerFlavor -> IO (Maybe Version)
hcVersion :: CompilerFlavor -> IO (Maybe Version)
hcVersion CompilerFlavor
hc = do
    Just String
hcpath <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompilerFlavor -> IO (Memoized (Maybe String))
hcExecutablePath CompilerFlavor
hc
    String
ver <- String -> [String] -> String -> IO String
readProcess String
hcpath
                 [case CompilerFlavor
hc of
                    CompilerFlavor
GHCJS -> String
"--numeric-ghc-version"
                    CompilerFlavor
_ -> String
"--numeric-version"]
                 String
""
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing String -> Maybe Version
parseVersion' (forall a. [a] -> Maybe a
listToMaybe (String -> [String]
lines String
ver))

-- | Use dpkg -S to convert the executable path to a debian binary
-- package name.
hcBinPkgName :: FilePath -> IO (Memoized (Maybe BinPkgName))
hcBinPkgName :: String -> IO (Memoized (Maybe BinPkgName))
hcBinPkgName String
path = forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar forall a b. (a -> b) -> a -> b
$ do
  String
s <- String -> [String] -> String -> IO String
readProcess String
"dpkg" [String
"-S", String
path] String
""
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
':')) (String -> [String]
lines String
s) of
    [] -> forall a. Maybe a
Nothing
    [String
name] -> forall a. a -> Maybe a
Just (String -> BinPkgName
BinPkgName String
name)
    [String]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unexpected output from " forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showCommandForUser String
"dpkg" [String
"-S", String
path] forall a. [a] -> [a] -> [a]
++ String
": ++ " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s

-- | What built in libraries does this haskell compiler provide?
aptCacheProvides :: BinPkgName -> IO (Memoized [PackageIdentifier])
aptCacheProvides :: BinPkgName -> IO (Memoized [PackageIdentifier])
aptCacheProvides = forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinPkgName -> IO [PackageIdentifier]
packageIdentifiers

packageIdentifiers :: BinPkgName -> IO [PackageIdentifier]
packageIdentifiers :: BinPkgName -> IO [PackageIdentifier]
packageIdentifiers BinPkgName
hcname =
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe PackageIdentifier
parsePackageIdentifier' forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe String
dropRequiredSuffix String
".conf" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
"package.conf.d") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Char
a Char
b -> (Char
a forall a. Eq a => a -> a -> Bool
== Char
'/') forall a. Eq a => a -> a -> Bool
== (Char
b forall a. Eq a => a -> a -> Bool
== Char
'/'))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinPkgName -> IO [String]
binPkgFiles BinPkgName
hcname

dropRequiredSuffix :: String -> String -> Maybe String
dropRequiredSuffix :: String -> String -> Maybe String
dropRequiredSuffix String
suff String
x =
    let (String
x', String
suff') = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
suff) String
x in if String
suff forall a. Eq a => a -> a -> Bool
== String
suff' then forall a. a -> Maybe a
Just String
x' else forall a. Maybe a
Nothing

-- | A list of the files in a binary deb
binPkgFiles :: BinPkgName -> IO [FilePath]
binPkgFiles :: BinPkgName -> IO [String]
binPkgFiles BinPkgName
hcname = String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"dpkg" [String
"-L", BinPkgName -> String
unBinPkgName BinPkgName
hcname] String
""

aptCacheConflicts :: String -> DebianVersion -> IO [BinPkgName]
aptCacheConflicts :: String -> DebianVersion -> IO [BinPkgName]
aptCacheConflicts String
hcname DebianVersion
ver =
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {source1}.
RegexContext Regex source1 (String, String, String, [String]) =>
source1 -> Maybe BinPkgName
doLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> IO (Memoized (Either SomeException String))
aptCacheDepends String
hcname (forall a. Show a => a -> String
show (DebianVersion -> Doc
prettyDebianVersion DebianVersion
ver)))
    where
      doLine :: source1 -> Maybe BinPkgName
doLine source1
s = case source1
s forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
"^[ ]*Conflicts:[ ]*<(.*)>$" :: (String, String, String, [String]) of
                   (String
_, String
_, String
_, [String
name]) -> forall a. a -> Maybe a
Just (String -> BinPkgName
BinPkgName String
name)
                   (String, String, String, [String])
_ -> forall a. Maybe a
Nothing

aptCacheDepends :: String -> String -> IO (Memoized (Either SomeException String))
aptCacheDepends :: String -> String -> IO (Memoized (Either SomeException String))
aptCacheDepends String
hcname String
ver =
    forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> [String] -> String -> IO String
readProcess String
"apt-cache" [String
"depends", String
hcname forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
ver] String
""))

aptVersions :: BinPkgName -> IO [DebianVersion]
aptVersions :: BinPkgName -> IO [DebianVersion]
aptVersions =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const []) (forall a b. (a -> b) -> [a] -> [b]
map forall string. ParseDebianVersion string => string -> DebianVersion
parseDebianVersion' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
' ')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"Reverse Depends:") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"Versions:") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< BinPkgName -> IO (Memoized (Either SomeException String))
aptCacheShowPkg)

aptCacheShowPkg :: BinPkgName -> IO (Memoized (Either SomeException String))
aptCacheShowPkg :: BinPkgName -> IO (Memoized (Either SomeException String))
aptCacheShowPkg BinPkgName
hcname =
    forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Memoized a)
memoizeMVar (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> [String] -> String -> IO String
readProcess String
"apt-cache" [String
"showpkg", BinPkgName -> String
unBinPkgName BinPkgName
hcname] String
""))

-- | 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 :: ReadP PackageIdentifier
parsePackageIdentifier =
  ([String], Version) -> PackageIdentifier
makeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. ReadP a -> ReadP sep -> ReadP [a]
endBy1 ((Char -> Bool) -> ReadP String
munch1 Char -> Bool
isAlphaNum) (Char -> ReadP Char
char Char
'-') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadP Version
parseCabalVersion)
    where
      makeId :: ([String], Version) -> PackageIdentifier
      makeId :: ([String], Version) -> PackageIdentifier
makeId ([String]
xs, Version
v) = PackageIdentifier {pkgName :: PackageName
pkgName = String -> PackageName
mkPackageName (forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String]
xs), pkgVersion :: Version
pkgVersion = Version
v}

parseMaybe :: ReadP a -> String -> Maybe a
parseMaybe :: forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP a
p = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== String
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
readP_to_S ReadP a
p

parseVersion' :: String -> Maybe Version
parseVersion' :: String -> Maybe Version
parseVersion' = forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP Version
parseCabalVersion

parseCabalVersion :: ReadP Version
parseCabalVersion :: ReadP Version
parseCabalVersion = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> Version
mkVersion' ReadP Version
parseVersion

parsePackageIdentifier' :: String -> Maybe PackageIdentifier
parsePackageIdentifier' :: String -> Maybe PackageIdentifier
parsePackageIdentifier' = forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP PackageIdentifier
parsePackageIdentifier

tests :: Test
tests :: Test
tests = [Test] -> Test
TestList [ Assertion -> Test
TestCase (forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"Bundled1"
                               (forall a. a -> Maybe a
Just (PackageName -> Version -> PackageIdentifier
PackageIdentifier (String -> PackageName
mkPackageName String
"HUnit") ([Int] -> Version
mkVersion [Int
1,Int
2,Int
3])))
                               (forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP PackageIdentifier
parsePackageIdentifier String
"HUnit-1.2.3"))
                 , Assertion -> Test
TestCase (forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"Bundled2"
                               forall a. Maybe a
Nothing
                               (forall a. ReadP a -> String -> Maybe a
parseMaybe ReadP PackageIdentifier
parsePackageIdentifier String
"HUnit-1.2.3 "))
                 , Assertion -> Test
TestCase forall a b. (a -> b) -> a -> b
$ do
                     String
ghc <- forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"which" [String
"ghc"] String
""
                     let ver :: Maybe String
ver = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/')) (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"/opt/ghc/" String
ghc)
                     [PackageIdentifier]
acp <- forall (m :: * -> *) a. MonadIO m => Memoized a -> m a
runMemoized forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BinPkgName -> IO (Memoized [PackageIdentifier])
aptCacheProvides (String -> BinPkgName
BinPkgName (String
"ghc" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
"-" forall a. [a] -> [a] -> [a]
++) Maybe String
ver))
                     let expected :: Set String
expected = forall a. Ord a => [a] -> Set a
Set.fromList
                                -- This is the package list for ghc-7.10.3
                                [String
"array", String
"base", String
"binary", String
"bin-package-db", String
"bytestring", String
"Cabal",
                                 String
"containers", String
"deepseq", String
"directory", String
"filepath", String
"ghc", String
"ghc-prim",
                                 String
"haskeline", String
"hoopl", String
"hpc", String
"integer-gmp", String
"pretty", String
"process",
                                 String
"template-haskell", String
"terminfo", String
"time", String
"transformers", String
"unix", String
"xhtml"]
                         actual :: Set String
actual = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName) [PackageIdentifier]
acp)
                         missing :: Maybe String -> Set String
missing (Just String
"8.0.1") = forall a. Ord a => [a] -> Set a
Set.fromList [String
"bin-package-db"]
                         missing (Just String
"8.0.2") = forall a. Ord a => [a] -> Set a
Set.fromList [String
"bin-package-db"]
                         missing Maybe String
_ = forall a. Monoid a => a
mempty
                         extra :: Maybe String -> Set String
extra (Just String
"7.8.4") = forall a. Ord a => [a] -> Set a
Set.fromList [String
"haskell2010",String
"haskell98",String
"old-locale",String
"old-time"]
                         extra (Just String
"8.0.1") = forall a. Ord a => [a] -> Set a
Set.fromList [String
"ghc-boot",String
"ghc-boot-th",String
"ghci"]
                         extra (Just String
"8.0.2") = forall a. Ord a => [a] -> Set a
Set.fromList [String
"ghc-boot",String
"ghc-boot-th",String
"ghci"]
                         extra Maybe String
_ = forall a. Monoid a => a
mempty
                     forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"Bundled4"
                       (Maybe String -> Set String
missing Maybe String
ver, Maybe String -> Set String
extra Maybe String
ver)
                       (forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set String
expected Set String
actual, forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set String
actual Set String
expected)
                 ]