module Debian.Debianize.Debianize
( cabalDebian
, callDebianize
, runDebianize
, runDebianize'
, debianize
, debianization
, writeDebianization
, describeDebianization
, compareDebianization
, validateDebianization
) where
import Control.Applicative ((<$>), (<*>), pure)
import Control.Exception (catch, throw)
import Data.Algorithm.Diff.Context (contextDiff)
import Data.Algorithm.Diff.Pretty (prettyDiff)
import Data.Lens.Lazy (getL, setL, modL)
import Data.List as List (unlines, intercalate, nub)
import Data.Map as Map (lookup, toList, elems)
import Data.Maybe
import Data.Monoid ((<>))
import Data.Set as Set (toList)
import Data.Text as Text (Text, unpack, split)
import Data.Version (Version)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Debianize.Atoms (Atoms, packageDescription, compat, watch, control, copyright, changelog, comments,
sourcePriority, sourceSection, debAction, validate, dryRun, debVersion, revision,
sourcePackageName, epochMap, extraLibMap)
import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..), PackageType(..))
import Debian.Debianize.Dependencies (debianName)
import Debian.Debianize.Files (toFileMap)
import Debian.Debianize.Finalize (finalizeDebianization)
import Debian.Debianize.Goodies (defaultAtoms, watchAtom)
import Debian.Debianize.Input (inputDebianization, inputCabalization, inputCopyright, inputMaintainer, inputChangeLog)
import Debian.Debianize.Options (options, compileArgs)
import Debian.Debianize.SubstVars (substvars)
import Debian.Debianize.Types (DebAction(..))
import Debian.Debianize.Utility (withCurrentDirectory, foldEmpty, replaceFile, zipMaps, indent)
import Debian.Policy (PackagePriority(Optional), Section(MainSection), getDebhelperCompatLevel)
import Debian.Relation (SrcPkgName(..), BinPkgName(BinPkgName), Relation(Rel))
import Debian.Release (parseReleaseName)
import Debian.Version (DebianVersion, parseDebianVersion, buildDebianVersion)
import Debian.Time (getCurrentLocalRFC822Time)
import Distribution.Package (PackageIdentifier(..))
import qualified Distribution.PackageDescription as Cabal
import Prelude hiding (writeFile, unlines)
import System.Console.GetOpt (usageInfo)
import System.Directory (doesFileExist, Permissions(executable), getPermissions, setPermissions, createDirectoryIfMissing)
import System.Environment (getArgs, getEnv, getProgName)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((</>), takeDirectory)
import System.IO.Error (catchIOError)
import System.Posix.Env (setEnv)
import System.Process (readProcessWithExitCode)
import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr)
import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))
cabalDebian :: IO ()
cabalDebian =
compileEnvironmentArgs defaultAtoms >>=
compileCommandlineArgs >>= \ atoms ->
case getL debAction atoms of
SubstVar debType -> substvars atoms debType
Debianize -> debianize "." atoms
Usage -> do
progName <- getProgName
let info = "Usage: " ++ progName ++ " [FLAGS]\n"
putStrLn (usageInfo info options)
compileEnvironmentArgs :: Atoms -> IO Atoms
compileEnvironmentArgs atoms0 =
(compileArgs <$> (read <$> getEnv "CABALDEBIAN") <*> pure atoms0) `catchIOError` const (return atoms0)
compileCommandlineArgs :: Atoms -> IO Atoms
compileCommandlineArgs atoms0 = compileArgs <$> getArgs <*> pure atoms0
callDebianize :: [String] -> IO ()
callDebianize args =
compileEnvironmentArgs defaultAtoms >>=
return . compileArgs args >>=
debianize "."
runDebianize :: [String] -> IO Bool
runDebianize args =
doesFileExist "debian/Debianize.hs" >>= \ exists ->
case exists of
False -> return False
True ->
putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ("debian/Debianize.hs" : args) "" >>= \ result ->
case result of
(ExitSuccess, _, _) -> return True
(code, out, err) ->
error ("runDebianize failed with " ++ show code ++ ":\n stdout: " ++ show out ++"\n stderr: " ++ show err)
putEnvironmentArgs :: [String] -> IO ()
putEnvironmentArgs fs = setEnv "CABALDEBIAN" (show fs) True
runDebianize' :: FilePath -> [String] -> IO Bool
runDebianize' top args = withCurrentDirectory top $ runDebianize args
debianize :: FilePath -> Atoms -> IO ()
debianize top atoms =
debianization top atoms >>= \ atoms' ->
if getL validate atoms'
then inputDebianization top >>= \ old -> return (validateDebianization old atoms')
else if getL dryRun atoms'
then inputDebianization top >>= \ old -> putStr ("Debianization (dry run):\n" ++ compareDebianization old atoms')
else writeDebianization top atoms'
debianization :: FilePath -> Atoms -> IO Atoms
debianization top atoms =
do log <- (Just <$> inputChangeLog "debian") `catch` (\ (_ :: IOError) -> return Nothing)
atoms' <- inputCabalization top atoms
date <- getCurrentLocalRFC822Time
maint <- inputMaintainer atoms' >>= maybe (error "Missing value for --maintainer") return
level <- getDebhelperCompatLevel
copyright <- withCurrentDirectory top $ inputCopyright (fromMaybe (error $ "cabalToDebianization: Failed to read cabal file in " ++ show top)
(getL packageDescription atoms'))
return $ debianization' date copyright maint level log atoms'
debianization' :: String
-> Text
-> NameAddr
-> Int
-> Maybe ChangeLog
-> Atoms
-> Atoms
debianization' date copyright' maint level log deb =
finalizeDebianization $
modL compat (maybe (Just level) Just) $
modL changelog (maybe log Just) $
setL sourcePriority (Just Optional) $
setL sourceSection (Just (MainSection "haskell")) $
setL watch (Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))) $
setL copyright (Just (Right copyright')) $
versionInfo maint date $
addExtraLibDependencies $
deb
where
pkgDesc = fromMaybe (error "debianization") $ getL packageDescription deb
versionInfo :: NameAddr -> String -> Atoms -> Atoms
versionInfo debianMaintainer date deb =
modL changelog (const (Just newLog)) $
modL control (\ y -> y { source = Just sourceName, Debian.maintainer = Just debianMaintainer }) deb
where
newLog =
case getL changelog deb of
Nothing -> ChangeLog [newEntry]
Just (ChangeLog oldEntries) ->
case dropWhile (\ entry -> logVersion entry > logVersion newEntry) oldEntries of
entry@(Entry {logVersion = d}) : older | d == logVersion newEntry -> ChangeLog (merge entry newEntry : older)
entries -> ChangeLog (newEntry : entries)
newEntry = Entry { logPackage = show (pretty sourceName)
, logVersion = convertVersion debinfo (pkgVersion pkgId)
, logDists = [parseReleaseName "unstable"]
, logUrgency = "low"
, logComments = List.unlines $ (map ((" * " <>) . List.intercalate "\n " . map unpack)) (fromMaybe [["Debianization generated by cabal-debian"]] (getL comments deb))
, logWho = show (pretty debianMaintainer)
, logDate = date }
sourceName :: SrcPkgName
sourceName = maybe (debianName deb Source' pkgId) id (getL sourcePackageName deb)
merge :: ChangeLogEntry -> ChangeLogEntry -> ChangeLogEntry
merge old new =
old { logComments = logComments old ++ logComments new
, logDate = date }
debinfo = maybe (Right (epoch, fromMaybe "" (getL revision deb))) Left (getL debVersion deb)
epoch = Map.lookup (pkgName pkgId) (getL epochMap deb)
pkgId = Cabal.package pkgDesc
pkgDesc = fromMaybe (error "versionInfo: no PackageDescription") $ getL packageDescription deb
convertVersion :: Either DebianVersion (Maybe Int, String) -> Version -> DebianVersion
convertVersion debinfo cabalVersion =
case debinfo of
Left override | override >= parseDebianVersion (show (pretty cabalVersion)) -> override
Left override -> error ("Version from --deb-version (" ++ show (pretty override) ++
") is older than hackage version (" ++ show (pretty cabalVersion) ++
"), maybe you need to unpin this package?")
Right (debianEpoch, debianRevision) ->
buildDebianVersion debianEpoch
(show (pretty cabalVersion))
(foldEmpty Nothing Just debianRevision)
addExtraLibDependencies :: Atoms -> Atoms
addExtraLibDependencies deb =
modL control (\ y -> y {binaryPackages = map f (binaryPackages (getL control deb))}) deb
where
f :: BinaryDebDescription -> BinaryDebDescription
f bin
| debianName deb Development (Cabal.package pkgDesc) == Debian.package bin
= bin { relations = g (relations bin) }
f bin = bin
g :: Debian.PackageRelations -> Debian.PackageRelations
g rels = rels { Debian.depends = Debian.depends rels ++
map anyrel' (concatMap (\ cab -> maybe [BinPkgName ("lib" ++ cab ++ "-dev")] Set.toList (Map.lookup cab (getL extraLibMap deb)))
(nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc)) }
pkgDesc = fromMaybe (error "addExtraLibDependencies: no PackageDescription") $ getL packageDescription deb
anyrel' :: BinPkgName -> [Relation]
anyrel' x = [Rel x Nothing Nothing]
writeDebianization :: FilePath -> Atoms -> IO ()
writeDebianization top d =
withCurrentDirectory top $
mapM_ (\ (path, text) ->
createDirectoryIfMissing True (takeDirectory path) >>
replaceFile path (unpack text))
(Map.toList (toFileMap d)) >>
getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True})
describeDebianization :: Atoms -> String
describeDebianization atoms =
concatMap (\ (path, text) -> path ++ ":\n" ++ indent " > " (unpack text)) (Map.toList (toFileMap atoms))
compareDebianization :: Atoms -> Atoms -> String
compareDebianization old new =
concat . Map.elems $ zipMaps doFile (toFileMap old) (toFileMap new)
where
doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String
doFile path (Just _) Nothing = Just (path ++ ": Deleted\n")
doFile path Nothing (Just n) = Just (path ++ ": Created\n" ++ indent " | " (unpack n))
doFile path (Just o) (Just n) =
if o == n
then Nothing
else Just (show (prettyDiff ("old" </> path) ("new" </> path) (contextDiff 2 (split (== '\n') o) (split (== '\n') n))))
doFile _path Nothing Nothing = error "Internal error in zipMaps"
validateDebianization :: Atoms -> Atoms -> ()
validateDebianization old new =
case () of
_ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion)))
| oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource)))
| oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages)))
| True -> ()
where
oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog old))))
newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL changelog new))))
oldSource = source . getL control $ old
newSource = source . getL control $ new
oldPackages = map Debian.package . binaryPackages . getL control $ old
newPackages = map Debian.package . binaryPackages . getL control $ new
unChangeLog :: ChangeLog -> [ChangeLogEntry]
unChangeLog (ChangeLog x) = x