module Debian.Debianize.Bundled
( builtIn
, aptCacheShowPkg
, aptCacheProvides
, aptCacheDepends
, aptCacheConflicts
, aptVersions
) where
import Control.DeepSeq (force)
import Control.Exception (SomeException, try)
import Data.Char (toLower)
import Data.Function (on)
import Data.Function.Memoize (memoize2, memoize3)
import Data.List (isPrefixOf, sortBy)
import Data.Map as Map (Map)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Version (parseVersion, Version(..))
import Debian.Debianize.VersionSplits (cabalFromDebian', DebBase(DebBase), VersionSplits)
import Debian.GHC ()
import Debian.Relation (BinPkgName(..))
import Debian.Relation.ByteString ()
import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion)
import Distribution.Package (PackageIdentifier(..), PackageName(..))
import Distribution.Simple.Compiler (CompilerFlavor(..))
import System.IO.Unsafe (unsafePerformIO)
import System.Process (readProcess)
import System.Unix.Chroot (useEnv)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Regex.TDFA ((=~))
builtIn :: Map PackageName VersionSplits -> CompilerFlavor -> FilePath -> PackageName -> Maybe Version
builtIn splits hc root lib = do
f $ builtIn' splits hc root
where
f :: (DebianVersion, [PackageIdentifier]) -> Maybe Version
f (hcv, ids) = case map pkgVersion (filter (\ i -> pkgName i == lib) ids) of
[] -> Nothing
[v] -> Just v
vs -> error $ show hc ++ "-" ++ show hcv ++ " in " ++ show root ++ " provides multiple versions of " ++ show lib ++ ": " ++ show vs
builtIn' :: Map PackageName VersionSplits -> CompilerFlavor -> FilePath -> (DebianVersion, [PackageIdentifier])
builtIn' splits hc root = do
case aptCacheProvides root hcname of
[] -> error $ "No versions of " ++ show hc ++ " (" ++ show hcname ++ ") in " ++ show root
((v, pids) : _) -> (v, mapMaybe (parsePackageID . unBinPkgName) pids)
where
BinPkgName hcname = BinPkgName (map toLower (show hc))
parsePackageID :: String -> Maybe PackageIdentifier
parsePackageID s =
case s =~ ("lib" ++ hcname ++ "-(.*)-dev-([0-9.]*)-.....$") :: (String, String, String, [String]) of
(_, _, _, [base, vs]) -> case listToMaybe (map fst $ filter ((== "") . snd) $ readP_to_S parseVersion $ vs) of
Just v -> Just (cabalFromDebian' splits (DebBase base) v)
Nothing -> Nothing
_ -> Nothing
aptCacheShowPkg :: FilePath -> String -> Either SomeException String
aptCacheShowPkg =
memoize2 (\ root hcname -> unsafePerformIO (try (chroot root (readProcess "apt-cache" ["showpkg", hcname] ""))))
where
chroot "/" = id
chroot root = useEnv root (return . force)
aptCacheProvides :: FilePath -> String -> [(DebianVersion, [BinPkgName])]
aptCacheProvides root hcname =
let lns = lines . either (\ (e :: SomeException) -> error $ "builtIn: " ++ show e) id $ aptCacheShowPkg root hcname
hcs = map words $ takeBetween (isPrefixOf "Provides:") (isPrefixOf "Reverse Provides:") lns
hcs' = reverse . sortBy (compare `on` fst) . map doHCVersion $ hcs in
hcs'
where
doHCVersion :: [String] -> (DebianVersion, [BinPkgName])
doHCVersion (versionString : "-" : deps) = (parseDebianVersion versionString, map BinPkgName deps)
doHCVersion x = error $ "Unexpected output from apt-cache: " ++ show x
aptCacheDepends :: FilePath -> String -> String -> Either SomeException String
aptCacheDepends =
memoize3 (\ root hcname ver -> unsafePerformIO (try (chroot root (readProcess "apt-cache" ["depends", hcname ++ "=" ++ ver] ""))))
where
chroot "/" = id
chroot root = useEnv root (return . force)
aptCacheConflicts :: FilePath -> String -> DebianVersion -> [BinPkgName]
aptCacheConflicts root hcname ver =
either (\ _ -> []) (mapMaybe doLine . lines) (aptCacheDepends root hcname (show (prettyDebianVersion ver)))
where
doLine s = case s =~ "^[ ]*Conflicts:[ ]*<(.*)>$" :: (String, String, String, [String]) of
(_, _, _, [name]) -> Just (BinPkgName name)
_ -> Nothing
aptVersions :: FilePath -> String -> [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)
takeBetween :: (a -> Bool) -> (a -> Bool) -> [a] -> [a]
takeBetween startPred endPred = takeWhile (not . endPred) . dropWhile startPred . dropWhile (not . startPred)