Bundled.hs

-- | Determine whether a specific version of a Haskell package is
-- bundled with into this particular version of the given compiler.

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
module Debian.Debianize.Bundled
    ( builtIn
    -- * Utilities
    , 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 ((=~))

-- | Find out what version, if any, of a cabal library is built into
-- the newest version of haskell compiler hc in environment root.  For
-- GHC this is done by looking at what virtual packages debian package
-- provides.  I have modified the ghcjs packaging to generate the
-- required virtual packages in the Provides line.  For other
-- compilers it maybe be unimplemented.
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

-- | Ok, lets see if we can infer the built in packages from the
-- Provides field returned by apt-cache.
builtIn' :: Map PackageName VersionSplits -> CompilerFlavor -> FilePath -> (DebianVersion, [PackageIdentifier])
builtIn' splits hc root = do
  -- Find out what library versions are provided by the latest version
  -- of the compiler.
  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))
      -- The virtual package id, which appears in the Provides
      -- line for the compiler package, is generated by the
      -- function package_id_to_virtual_package in Dh_Haskell.sh.
      -- It consists of the library's debian package name and the
      -- first five characters of the checksum.
      -- parsePID "libghc-unix-dev-2.7.0.1-2a456" -> Just (PackageIdentifier "unix" (Version [2,7,0,1] []))
      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)