module Debian.Debianize.Finalize
( debianization
, finalizeDebianization'
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad as List (mapM_)
import Control.Monad.State (get, modify)
import Control.Monad.Trans (liftIO, MonadIO)
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Char (toLower)
import Data.Digest.Pure.MD5 (md5)
import Data.Lens.Lazy (access, getL)
import Data.List as List (intercalate, map, nub, unlines)
import Data.Map as Map (delete, elems, lookup, map, Map, toList, unionsWith)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid ((<>))
import Data.Set as Set (difference, filter, fromList, map, null, Set, singleton, toList, union, unions)
import Data.Set.Extra as Set (mapM_)
import Data.Text as Text (pack, unlines, unpack)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Debianize.BuildDependencies (debianBuildDeps, debianBuildDepsIndep)
import Debian.Debianize.Changelog (dropFutureEntries)
import Debian.Debianize.DebianName (debianName)
import Debian.Debianize.Goodies (backupAtoms, describe, execAtoms, serverAtoms, siteAtoms, watchAtom)
import Debian.Debianize.Input (dataDir, inputCabalization, inputChangeLog, inputMaintainer)
import Debian.Debianize.Monad as Monad (DebT)
import Debian.Debianize.Options (compileCommandlineArgs, compileEnvironmentArgs)
import Debian.Debianize.Prelude ((%=), (+++=), (+=), foldEmpty, fromEmpty, fromSingleton, (~=), (~?=))
import qualified Debian.Debianize.Types as T (apacheSite, backups, binaryArchitectures, binaryPackages, binarySection, breaks, buildDepends, buildDependsIndep, buildDir, builtUsing, changelog, comments, compat, conflicts, debianDescription, debVersion, depends, epochMap, executable, extraDevDeps, extraLibMap, file, install, installCabalExec, installCabalExecTo, installData, installDir, installTo, intermediateFiles, license, link, maintainer, noDocumentationLibrary, noProfilingLibrary, noHoogle, packageDescription, packageType, preDepends, provides, recommends, replaces, revision, rulesFragments, serverInfo, source, sourcePackageName, sourcePriority, sourceSection, suggests, utilsPackageNames, verbosity, watch, website)
import qualified Debian.Debianize.Types.Atoms as A (InstallFile(execName, sourceDir), showAtoms, compilerFlavor)
import qualified Debian.Debianize.Types.BinaryDebDescription as B (BinaryDebDescription, package, PackageType(Development, Documentation, Exec, Profiling, Source', Utilities))
import Debian.Orphans ()
import Debian.Policy (getDebhelperCompatLevel, haskellMaintainer, PackageArchitectures(Any, All), PackagePriority(Optional), Section(..))
import Debian.Pretty (pretty)
import Debian.Relation (BinPkgName, BinPkgName(BinPkgName), Relation(Rel), Relations)
import qualified Debian.Relation as D (BinPkgName(BinPkgName), Relation(..))
import Debian.Release (parseReleaseName)
import Debian.Time (getCurrentLocalRFC822Time)
import Debian.Version (buildDebianVersion, DebianVersion, parseDebianVersion)
import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName(PackageName))
import Distribution.PackageDescription (PackageDescription)
import Distribution.PackageDescription as Cabal (allBuildInfo, BuildInfo(buildable, extraLibs), Executable(buildInfo, exeName))
import qualified Distribution.PackageDescription as Cabal (PackageDescription(dataDir, dataFiles, executables, library, license, package))
import Prelude hiding (init, log, map, unlines, unlines, writeFile)
import System.FilePath ((<.>), (</>), makeRelative, splitFileName, takeDirectory, takeFileName)
debianization :: (MonadIO m, Functor m) => DebT m () -> DebT m () -> DebT m ()
debianization init customize =
do compileEnvironmentArgs
compileCommandlineArgs
inputCabalization
inputChangeLog
inputMaintainer
init
customize
finalizeDebianization'
finalizeDebianization' :: (MonadIO m, Functor m) => DebT m ()
finalizeDebianization' =
do date <- liftIO getCurrentLocalRFC822Time
debhelperCompat <- liftIO getDebhelperCompatLevel
finalizeDebianization date debhelperCompat
access T.verbosity >>= \ vb -> when (vb >= 3) (get >>= liftIO . A.showAtoms)
finalizeDebianization :: (MonadIO m, Functor m) => String -> Maybe Int -> DebT m ()
finalizeDebianization date debhelperCompat =
do addExtraLibDependencies
Just pkgDesc <- access T.packageDescription
T.watch ~?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))
T.sourceSection ~?= Just (MainSection "haskell")
T.sourcePriority ~?= Just Optional
T.compat ~?= debhelperCompat
finalizeChangelog date
finalizeControl
T.license ~?= Just (Cabal.license pkgDesc)
expandAtoms
access T.executable >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
access T.backups >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
access T.serverInfo >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
access T.website >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
putBuildDeps pkgDesc
librarySpecs pkgDesc
makeUtilsPackages pkgDesc
expandAtoms
finalizeDescriptions
finalizeDescriptions :: (Monad m, Functor m) => DebT m ()
finalizeDescriptions = access T.binaryPackages >>= List.mapM_ finalizeDescription
finalizeDescription :: (Monad m, Functor m) => B.BinaryDebDescription -> DebT m ()
finalizeDescription bdd =
do let b = getL B.package bdd
cabDesc <- describe b
T.debianDescription b ~?= Just cabDesc
debianVersion :: Monad m => DebT m DebianVersion
debianVersion =
do pkgDesc <- access T.packageDescription >>= maybe (error "debianVersion: no PackageDescription") return
let pkgId = Cabal.package pkgDesc
epoch <- debianEpoch (pkgName pkgId)
debVer <- access T.debVersion
case debVer of
Just override
| override < parseDebianVersion (show (pretty (pkgVersion pkgId))) ->
error ("Version from --deb-version (" ++ show (pretty override) ++
") is older than hackage version (" ++ show (pretty (pkgVersion pkgId)) ++
"), maybe you need to unpin this package?")
Just override -> return override
Nothing ->
do let ver = show (pretty (pkgVersion pkgId))
rev <- get >>= return . getL T.revision >>= return . foldEmpty Nothing Just . fromMaybe ""
return $ buildDebianVersion epoch ver rev
debianEpoch :: Monad m => PackageName -> DebT m (Maybe Int)
debianEpoch name = get >>= return . Map.lookup name . getL T.epochMap
finalizeSourceName :: Monad m => DebT m ()
finalizeSourceName =
do debName <- debianName B.Source'
T.sourcePackageName ~?= Just debName
finalizeMaintainer :: Monad m => DebT m ()
finalizeMaintainer =
T.maintainer ~?= Just haskellMaintainer
finalizeControl :: Monad m => DebT m ()
finalizeControl =
do finalizeSourceName
finalizeMaintainer
Just src <- access T.sourcePackageName
maint <- access T.maintainer >>= return . fromMaybe (error "No maintainer")
T.source ~= Just src
T.maintainer ~= Just maint
finalizeChangelog :: Monad m => String -> DebT m ()
finalizeChangelog date =
do finalizeSourceName
finalizeMaintainer
ver <- debianVersion
src <- access T.sourcePackageName
Just maint <- access T.maintainer
cmts <- access T.comments
T.changelog %= fmap (dropFutureEntries ver)
T.changelog %= fixLog src ver cmts maint
where
fixLog src ver cmts _maint (Just (ChangeLog (entry : older))) | logVersion entry == ver =
Just (ChangeLog (entry { logPackage = show (pretty src)
, logComments = logComments entry ++ "\n" ++
(List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) (fromMaybe [] cmts))
} : older))
fixLog src ver cmts maint log =
Just (ChangeLog (Entry { logPackage = show (pretty src)
, logVersion = ver
, logDists = [parseReleaseName "unstable"]
, logUrgency = "low"
, logComments = List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack)
(fromMaybe [["Debianization generated by cabal-debian"]] cmts)
, logWho = show (pretty maint)
, logDate = date } : maybe [] (\ (ChangeLog entries) -> entries) log))
addExtraLibDependencies :: (Monad m, Functor m) => DebT m ()
addExtraLibDependencies =
do pkgDesc <- access T.packageDescription >>= maybe (error "addExtraLibDependencies: no PackageDescription") return
devName <- debianName B.Development
libMap <- access T.extraLibMap
binNames <- List.map (getL B.package) <$> access T.binaryPackages
when (any (== devName) binNames) (T.depends devName %= \ deps -> deps ++ g pkgDesc libMap)
where
g :: PackageDescription -> Map String Relations -> Relations
g pkgDesc libMap = concatMap (devDep libMap) (nub $ concatMap Cabal.extraLibs $ Cabal.allBuildInfo $ pkgDesc)
devDep :: Map String Relations -> String -> Relations
devDep libMap cab = maybe [[Rel (BinPkgName ("lib" ++ cab ++ "-dev")) Nothing Nothing]] id (Map.lookup cab libMap)
putBuildDeps :: MonadIO m => PackageDescription -> DebT m ()
putBuildDeps pkgDesc =
do deps <- debianBuildDeps pkgDesc
depsIndep <- debianBuildDepsIndep pkgDesc
T.buildDepends ~= deps
T.buildDependsIndep ~= depsIndep
cabalExecBinaryPackage :: Monad m => BinPkgName -> DebT m ()
cabalExecBinaryPackage b =
do T.packageType b ~?= Just B.Exec
T.binaryArchitectures b ~?= Just Any
T.binarySection b ~?= Just (MainSection "misc")
desc <- describe b
T.debianDescription b ~?= Just desc
binaryPackageRelations b B.Exec
where
binaryPackageRelations :: Monad m => BinPkgName -> B.PackageType -> DebT m ()
binaryPackageRelations b typ =
do edds <- access T.extraDevDeps
T.depends b %= \ rels -> [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++
(if typ == B.Development then edds else []) ++ rels
T.recommends b %= \ rels -> [anyrel "${haskell:Recommends}"] ++ rels
T.suggests b %= \ rels -> [anyrel "${haskell:Suggests}"] ++ rels
T.preDepends b ~= []
T.breaks b ~= []
T.conflicts b %= \ rels -> [anyrel "${haskell:Conflicts}"] ++ rels
T.provides b %= \ rels -> [anyrel "${haskell:Provides}"] ++ rels
T.replaces b %= \ rels -> [anyrel "${haskell:Replaces}"] ++ rels
T.builtUsing b ~= []
librarySpecs :: Monad m => PackageDescription -> DebT m ()
librarySpecs pkgDesc =
do debName <- debianName B.Documentation
let dev = isJust (Cabal.library pkgDesc)
doc <- get >>= return . not . getL T.noDocumentationLibrary
prof <- get >>= return . not . getL T.noProfilingLibrary
cfl <- access A.compilerFlavor
hoogle <- get >>= return . not . getL T.noHoogle
when dev (librarySpec Any B.Development)
when (dev && prof && cfl == GHC) (librarySpec Any B.Profiling)
when (dev && doc && hoogle)
(do docSpecsParagraph
T.link +++= (debName, singleton ("/usr/share/doc" </> show (pretty debName) </> "html" </> cabal <.> "txt",
"/usr/lib/ghc-doc/hoogle" </> List.map toLower cabal <.> "txt")))
where
PackageName cabal = pkgName (Cabal.package pkgDesc)
docSpecsParagraph :: Monad m => DebT m ()
docSpecsParagraph =
do b <- debianName B.Documentation
binaryPackageRelations b B.Development
T.packageType b ~?= Just B.Documentation
desc <- describe b
T.packageType b ~?= Just B.Documentation
T.binaryArchitectures b ~= Just All
T.binarySection b ~?= Just (MainSection "doc")
T.debianDescription b ~?= Just desc
librarySpec :: Monad m => PackageArchitectures -> B.PackageType -> DebT m ()
librarySpec arch typ =
do b <- debianName typ
binaryPackageRelations b B.Development
T.packageType b ~?= Just typ
desc <- describe b
T.packageType b ~?= Just typ
T.binaryArchitectures b ~?= Just arch
T.debianDescription b ~?= Just desc
makeUtilsPackages :: forall m. (Monad m, Functor m) => PackageDescription -> DebT m ()
makeUtilsPackages pkgDesc =
do
installedDataMap <- Map.unionsWith Set.union
<$> (sequence [(Map.map (Set.map fst) <$> access T.install),
(Map.map (Set.map fst) <$> access T.installTo),
(Map.map (Set.map fst) <$> access T.installData)]) :: DebT m (Map BinPkgName (Set FilePath))
installedExecMap <- Map.unionsWith Set.union
<$> (sequence [(Map.map (Set.map fst) <$> access T.installCabalExec),
(Map.map (Set.map fst) <$> access T.installCabalExecTo)]) :: DebT m (Map BinPkgName (Set String))
insExecPkg <- access T.executable >>= return . Set.map ename . Set.fromList . elems
let installedData = Set.map (\ a -> (a, a)) $ Set.unions (Map.elems installedDataMap)
installedExec = Set.unions (Map.elems installedExecMap)
let prefixPath = Cabal.dataDir pkgDesc
let dataFilePaths = Set.fromList (zip (List.map (prefixPath </>) (Cabal.dataFiles pkgDesc)) (Cabal.dataFiles pkgDesc)) :: Set (FilePath, FilePath)
execFilePaths = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc))) :: Set FilePath
let availableData = Set.union installedData dataFilePaths
availableExec = Set.union installedExec execFilePaths
access T.utilsPackageNames >>= \ names ->
when (Set.null names) (debianName B.Utilities >>= \ name -> T.utilsPackageNames ~= singleton name)
utilsPackages <- access T.utilsPackageNames
let installedDataOther = Set.map (\ a -> (a, a)) $ Set.unions $ Map.elems $ foldr (Map.delete) installedDataMap (Set.toList utilsPackages)
installedExecOther =
Set.union (tr "insExecPkg: " insExecPkg) $
Set.unions $ Map.elems $ foldr (Map.delete) (tr "installedExec: " installedExecMap) (Set.toList utilsPackages)
let utilsData = Set.difference availableData installedDataOther
utilsExec = Set.difference (tr "availableExec: " availableExec) (tr "installedExecOther: " installedExecOther)
let utilsDataMissing = Set.difference utilsData installedData
utilsExecMissing = Set.difference utilsExec installedExec
when (not (Set.null utilsData && Set.null utilsExec))
(Set.mapM_ (\ p -> do
T.rulesFragments += (pack ("build" </> show (pretty p) ++ ":: build-$(HC)-stamp"))
T.binaryArchitectures p ~?= Just (if Set.null utilsExec then All else Any)
T.binarySection p ~?= Just (MainSection "misc")
binaryPackageRelations p B.Utilities) utilsPackages)
Set.mapM_ (\ p -> Set.mapM_ (\ pair -> T.installData +++= (p, singleton pair)) utilsDataMissing) utilsPackages
Set.mapM_ (\ p -> Set.mapM_ (\ name -> T.installCabalExec +++= (p, singleton (name, "usr/bin"))) (tr "utilsExecMissing: " utilsExecMissing)) utilsPackages
where
ename i =
case A.sourceDir i of
(Nothing) -> A.execName i
(Just s) -> s </> A.execName i
tr :: Show a => String -> a -> a
tr _label x = x
expandAtoms :: Monad m => DebT m ()
expandAtoms =
do builddir <- get >>= return . fromEmpty (singleton "dist-ghc/build") . getL T.buildDir
dDir <- access T.packageDescription >>= maybe (error "expandAtoms") (return . dataDir)
expandApacheSites
expandInstallCabalExecs (fromSingleton (error "no builddir") (\ xs -> error $ "multiple builddirs:" ++ show xs) builddir)
expandInstallCabalExecTo (fromSingleton (error "no builddir") (\ xs -> error $ "multiple builddirs:" ++ show xs) builddir)
expandInstallData dDir
expandInstallTo
expandFile
expandWebsite
expandServer
expandBackups
expandExecutable
where
expandApacheSites :: Monad m => DebT m ()
expandApacheSites =
do mp <- get >>= return . getL T.apacheSite
List.mapM_ expandApacheSite (Map.toList mp)
where
expandApacheSite (b, (dom, log, text)) =
do T.link +++= (b, singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom))
T.installDir +++= (b, singleton log)
T.file +++= (b, singleton ("/etc/apache2/sites-available" </> dom, text))
expandInstallCabalExecs :: Monad m => FilePath -> DebT m ()
expandInstallCabalExecs builddir =
do mp <- get >>= return . getL T.installCabalExec
List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (name, dst) -> T.install +++= (b, singleton (builddir </> name </> name, dst))) pairs) (Map.toList mp)
expandInstallCabalExecTo :: Monad m => FilePath -> DebT m ()
expandInstallCabalExecTo builddir =
do mp <- get >>= return . getL T.installCabalExecTo
List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (n, d) -> T.rulesFragments += (Text.unlines
[ pack ("binary-fixup" </> show (pretty b)) <> "::"
, "\tinstall -Dps " <> pack (builddir </> n </> n) <> " " <> pack ("debian" </> show (pretty b) </> makeRelative "/" d) ])) pairs) (Map.toList mp)
expandInstallData :: Monad m => FilePath -> DebT m ()
expandInstallData dDir =
do mp <- get >>= return . getL T.installData
List.mapM_ (\ (b, pairs) -> Set.mapM_ (\ (s, d) ->
if takeFileName s == takeFileName d
then T.install +++= (b, singleton (s, (dDir </> makeRelative "/" (takeDirectory d))))
else T.installTo +++= (b, singleton (s, (dDir </> makeRelative "/" d)))) pairs) (Map.toList mp)
expandInstallTo :: Monad m => DebT m ()
expandInstallTo =
do mp <- get >>= return . getL T.installTo
List.mapM_ (\ (p, pairs) -> Set.mapM_ (\ (s, d) -> T.rulesFragments += (Text.unlines
[ pack ("binary-fixup" </> show (pretty p)) <> "::"
, "\tinstall -Dp " <> pack s <> " " <> pack ("debian" </> show (pretty p) </> makeRelative "/" d) ])) pairs) (Map.toList mp)
expandFile :: Monad m => DebT m ()
expandFile =
do mp <- get >>= return . getL T.file
List.mapM_ (\ (p, pairs) -> Set.mapM_ (\ (path, s) ->
do let (destDir', destName') = splitFileName path
tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack s)))
tmpPath = tmpDir </> destName'
T.intermediateFiles += (tmpPath, s)
T.install +++= (p, singleton (tmpPath, destDir'))) pairs) (Map.toList mp)
expandWebsite :: Monad m => DebT m ()
expandWebsite =
do mp <- get >>= return . getL T.website
List.mapM_ (\ (b, site) -> modify (siteAtoms b site)) (Map.toList mp)
expandServer :: Monad m => DebT m ()
expandServer =
do mp <- get >>= return . getL T.serverInfo
List.mapM_ (\ (b, x) -> modify (serverAtoms b x False)) (Map.toList mp)
expandBackups :: Monad m => DebT m ()
expandBackups =
do mp <- get >>= return . getL T.backups
List.mapM_ (\ (b, name) -> modify (backupAtoms b name)) (Map.toList mp)
expandExecutable :: Monad m => DebT m ()
expandExecutable =
do mp <- get >>= return . getL T.executable
List.mapM_ (\ (b, f) -> modify (execAtoms b f)) (Map.toList mp)
data Dependency_
= BuildDepends Dependency
| BuildTools Dependency
| PkgConfigDepends Dependency
| ExtraLibs Relations
deriving (Eq, Show)
anyrel :: String -> [D.Relation]
anyrel x = anyrel' (D.BinPkgName x)
anyrel' :: D.BinPkgName -> [D.Relation]
anyrel' x = [D.Rel x Nothing Nothing]