module Debian.Debianize.SubstVars
( substvars
) where
import Control.Exception (SomeException, try)
import Control.Monad (foldM)
import Control.Monad.Reader (ReaderT(runReaderT))
import Control.Monad.Trans (lift)
import Data.Lens.Lazy (getL, modL)
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Text (pack)
import Debian.Control
import Debian.Debianize.Atoms (Atoms, compiler, dryRun, packageInfo)
import Debian.Debianize.Dependencies (cabalDependencies, debDeps, debNameFromType, filterMissing)
import Debian.Debianize.Input (inputCabalization)
import Debian.Debianize.Types (Top(Top), PackageInfo(PackageInfo, cabalName, devDeb, profDeb, docDeb), DebType)
import Debian.Debianize.Utility (buildDebVersionMap, DebMap, showDeps, dpkgFileMap, cond, debOfFile, (!), diffFile, replaceFile)
import qualified Debian.Relation as D
import Distribution.Package (Dependency(..), PackageName(PackageName))
import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..))
import Distribution.Simple.Utils (die)
import Distribution.Text (display)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>))
import Text.PrettyPrint.ANSI.Leijen (pretty)
substvars :: Atoms
-> DebType
-> IO ()
substvars atoms debType =
do atoms' <- inputCabalization (Top ".") atoms
debVersions <- buildDebVersionMap
atoms'' <- libPaths (fromMaybe (error "substvars") $ getL compiler atoms') debVersions atoms'
control <- readFile "debian/control" >>= either (error . show) return . parseControl "debian/control"
substvars' atoms'' debType control
substvars' :: Atoms -> DebType -> Control' String -> IO ()
substvars' atoms debType control =
case (missingBuildDeps, path) of
([], Just path') ->
readFile path' >>= \ old ->
let new = addDeps old in
diffFile path' (pack new) >>= maybe (putStrLn ("cabal-debian substvars: No updates found for " ++ show path'))
(\ diff -> if getL dryRun atoms then putStr diff else replaceFile path' new)
([], Nothing) -> return ()
(missing, _) ->
die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map (show . pretty . fst) missing) ++
"\nIf this is an obsolete package you may need to withdraw the old versions from the\n" ++
"upstream repository, and uninstall and purge it from your local system.")
where
addDeps old =
case partition (isPrefixOf "haskell:Depends=") (lines old) of
([], other) -> unlines (("haskell:Depends=" ++ showDeps (filterMissing atoms deps)) : other)
(hdeps, more) ->
case deps of
[] -> unlines (hdeps ++ more)
_ -> unlines (map (++ (", " ++ showDeps (filterMissing atoms deps))) hdeps ++ more)
path = fmap (\ (D.BinPkgName x) -> "debian/" ++ x ++ ".substvars") name
name = debNameFromType control debType
deps = debDeps debType atoms control
missingBuildDeps =
let requiredDebs =
concat (map (\ (Dependency name _) ->
case Map.lookup name (getL packageInfo atoms) of
Just info ->
let prof = maybe (devDeb info) Just (profDeb info) in
let doc = docDeb info in
catMaybes [prof, doc]
Nothing -> []) (cabalDependencies atoms)) in
filter (not . (`elem` buildDepNames) . fst) requiredDebs
buildDepNames :: [D.BinPkgName]
buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps)
buildDeps :: D.Relations
buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi)
bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control
bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control
libPaths :: Compiler -> DebMap -> Atoms -> IO Atoms
libPaths compiler debVersions atoms
| compilerFlavor compiler == GHC =
do a <- getDirPaths "/usr/lib"
b <- getDirPaths "/usr/lib/haskell-packages/ghc/lib"
dpkgFileMap >>= runReaderT (foldM (packageInfo' compiler debVersions) atoms (a ++ b))
| True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler)
where
getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id
packageInfo' :: Compiler -> DebMap -> Atoms -> (FilePath, String) -> ReaderT (Map.Map FilePath (Set.Set D.BinPkgName)) IO Atoms
packageInfo' compiler debVersions atoms (d, f) =
case parseNameVersion f of
Nothing -> return atoms
Just (p, v) -> lift (doesDirectoryExist (d </> f </> cdir)) >>= cond (return atoms) (info (p, v))
where
parseNameVersion s =
case (break (== '-') (reverse s)) of
(_a, "") -> Nothing
(a, b) -> Just (reverse (tail b), reverse a)
cdir = display (compilerId compiler)
info (p, v) =
do dev <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ ".a$")
prof <- debOfFile ("^" ++ d </> p ++ "-" ++ v </> cdir </> "libHS" ++ p ++ "-" ++ v ++ "_p.a$")
doc <- debOfFile ("/" ++ p ++ ".haddock$")
return $ modL packageInfo (Map.insert
(PackageName p)
(PackageInfo { cabalName = PackageName p
, devDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) dev
, profDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) prof
, docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) atoms