module Debian.Debianize.Finalize
( debianization
, finalizeDebianization'
) where
import Control.Applicative ((<$>))
import Control.Category ((.))
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.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, toList, insertWith)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid ((<>), mempty)
import Data.Set as Set (difference, filter, fromList, map, null, Set, singleton, toList, union, unions, fold)
import Data.Set.Extra as Set (mapM_)
import Data.Text as Text (Text, pack, unlines, unpack, intercalate)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Debianize.BuildDependencies (debianBuildDeps, debianBuildDepsIndep)
import Debian.Debianize.Changelog (dropFutureEntries)
import Debian.Debianize.DebianName (debianName, debianNameBase)
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 ((%=), (+=), 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, installData, installDir, installTo, intermediateFiles, link, maintainer, noDocumentationLibrary, noProfilingLibrary, omitProfVersionDeps, packageDescription, packageType, preDepends, provides, recommends, replaces, revision, rulesFragments, serverInfo, standardsVersion, source, sourceFormat, sourcePackageName, sourcePriority, sourceSection, suggests, utilsPackageNameBase, verbosity, watch, website, control, homepage, official, vcsFields)
import qualified Debian.Debianize.Types.Atoms as A (InstallFile(execName, sourceDir), showAtoms, compilerFlavors, Atom(..), atomSet)
import qualified Debian.Debianize.Types.BinaryDebDescription as B (BinaryDebDescription, package, PackageType(Development, Documentation, Exec, Profiling, Source, HaskellSource, Utilities), PackageType)
import qualified Debian.Debianize.Types.SourceDebDescription as S (xDescription, VersionControlSpec(..))
import Debian.Debianize.VersionSplits (DebBase(DebBase))
import Debian.Orphans ()
import Debian.Pretty (ppDisplay, PP(..))
import Debian.Policy (getDebhelperCompatLevel, haskellMaintainer, PackageArchitectures(Any, All), PackagePriority(Extra), Section(..), SourceFormat(Quilt3), parseStandardsVersion)
import Debian.Relation (BinPkgName, BinPkgName(BinPkgName), SrcPkgName(SrcPkgName), 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))
#if MIN_VERSION_Cabal(1,21,0)
import Distribution.Compiler (CompilerFlavor(GHCJS))
#endif
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, package))
import Prelude hiding (init, log, map, unlines, unlines, writeFile, (.))
import System.FilePath ((</>), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName)
import Text.PrettyPrint.HughesPJClass (Pretty(pPrint))
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
hcs <- Set.toList <$> access A.compilerFlavors
finalizeSourceName B.HaskellSource
List.mapM_ checkOfficialSettings hcs
List.mapM_ addExtraLibDependencies hcs
Just pkgDesc <- access T.packageDescription
T.watch ~?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))
T.sourceSection ~?= Just (MainSection "haskell")
T.sourcePriority ~?= Just Extra
T.sourceFormat ~?= Just Quilt3
T.compat ~?= debhelperCompat
finalizeChangelog date
finalizeControl
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
List.mapM_ (librarySpecs pkgDesc) hcs
List.mapM_ (makeUtilsPackage pkgDesc) hcs
expandAtoms
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 (ppDisplay (pkgVersion pkgId)) ->
error ("Version from --deb-version (" ++ ppDisplay override ++
") is older than hackage version (" ++ ppDisplay (pkgVersion pkgId) ++
"), maybe you need to unpin this package?")
Just override -> return override
Nothing ->
do let ver = ppDisplay (pkgVersion pkgId)
rev <- access T.revision
let revMB = case rev of Nothing -> Nothing
Just "" -> Nothing
Just "-" -> Nothing
Just ('-':r) -> Just r
Just _ -> error "The Debian revision needs to start with a dash"
return $ buildDebianVersion epoch ver revMB
debianEpoch :: Monad m => PackageName -> DebT m (Maybe Int)
debianEpoch name = get >>= return . Map.lookup name . getL T.epochMap
finalizeSourceName :: (Monad m, Functor m) => B.PackageType -> DebT m ()
finalizeSourceName typ =
do DebBase debName <- debianNameBase
T.sourcePackageName ~?= Just (SrcPkgName (case typ of
B.HaskellSource -> "haskell-" ++ debName
B.Source -> debName
_ -> error $ "finalizeSourceName: " ++ show typ))
finalizeMaintainer :: Monad m => DebT m ()
finalizeMaintainer =
T.maintainer ~?= Just haskellMaintainer
finalizeControl :: (Monad m, Functor m) => DebT m ()
finalizeControl =
do finalizeMaintainer
Just src <- access T.sourcePackageName
maint <- access T.maintainer >>= return . fromMaybe (error "No maintainer")
T.source ~= Just src
T.maintainer ~= Just maint
desc <- describe
(S.xDescription . T.control) ~?= Just desc
finalizeChangelog :: (Monad m, Functor m) => String -> DebT m ()
finalizeChangelog date =
do 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 (pPrint (PP 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 (pPrint (PP src))
, logVersion = ver
, logDists = [parseReleaseName "UNRELEASED"]
, logUrgency = "low"
, logComments = List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack)
(fromMaybe [["Debianization generated by cabal-debian"]] cmts)
, logWho = ppDisplay maint
, logDate = date } : maybe [] (\ (ChangeLog entries) -> entries) log))
addExtraLibDependencies :: (Monad m, Functor m) => CompilerFlavor -> DebT m ()
addExtraLibDependencies hc =
do pkgDesc <- access T.packageDescription >>= maybe (error "addExtraLibDependencies: no PackageDescription") return
devName <- debianName B.Development hc
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)
checkOfficialSettings :: (Monad m, Functor m) => CompilerFlavor -> DebT m ()
checkOfficialSettings flavor =
do o <- access T.official
when o $ case flavor of
GHC -> officialSettings
_ -> error $ "There is no official packaging for " ++ show flavor
officialSettings :: (Monad m, Functor m) => DebT m ()
officialSettings =
do pkgDesc <- access T.packageDescription >>= maybe (error "officialSettings: no PackageDescription") return
let PackageName cabal = pkgName (Cabal.package pkgDesc)
T.standardsVersion ~?= Just (parseStandardsVersion "3.9.5")
T.homepage ~?= Just ("http://hackage.haskell.org/package/" <> pack cabal)
T.omitProfVersionDeps ~= True
SrcPkgName src <- access T.sourcePackageName >>= maybe (error "officialSettings: no sourcePackageName") return
T.vcsFields %= Set.union (Set.fromList
[ S.VCSBrowser $ "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/" <> pack src
, S.VCSDarcs $ "http://darcs.debian.org/pkg-haskell/" <> pack src
])
putBuildDeps :: (MonadIO m, Functor 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")
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 "${haskell:Depends}", anyrel "${misc:Depends}"] ++
[anyrel "${shlibs:Depends}" | typ `notElem` [B.Profiling, B.Documentation] ] ++
edds ++ 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 -> (if typ /= B.Documentation then [anyrel "${haskell:Provides}"] else []) ++ rels
T.builtUsing b ~= []
librarySpecs :: (Monad m, Functor m) => PackageDescription -> CompilerFlavor -> DebT m ()
librarySpecs pkgDesc hc =
do let dev = isJust (Cabal.library pkgDesc)
doc <- get >>= return . not . getL T.noDocumentationLibrary
prof <- get >>= return . not . getL T.noProfilingLibrary
when dev (librarySpec Any B.Development hc)
when (dev && prof && hc == GHC) (librarySpec Any B.Profiling hc)
when (dev && doc) (docSpecsParagraph hc)
docSpecsParagraph :: (Monad m, Functor m) => CompilerFlavor -> DebT m ()
docSpecsParagraph hc =
do b <- debianName B.Documentation hc
binaryPackageRelations b B.Documentation
T.packageType b ~?= Just B.Documentation
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, Functor m) => PackageArchitectures -> B.PackageType -> CompilerFlavor -> DebT m ()
librarySpec arch typ hc =
do b <- debianName typ hc
binaryPackageRelations b typ
T.packageType b ~?= Just typ
T.packageType b ~?= Just typ
T.binaryArchitectures b ~?= Just arch
T.debianDescription b ~?= Just desc
desc :: Text
desc = Text.intercalate "\n "
["${haskell:ShortDescription}${haskell:ShortBlurb}",
" ${haskell:LongDescription}",
" .",
" ${haskell:Blurb}"]
makeUtilsPackage :: forall m. (MonadIO m, Functor m) => PackageDescription -> CompilerFlavor -> DebT m ()
makeUtilsPackage pkgDesc hc =
do
installedDataMap <- Set.fold (\ x r ->
case x of
A.Install b from _ -> Map.insertWith Set.union b (singleton from) r
A.InstallTo b from _ -> Map.insertWith Set.union b (singleton from) r
A.InstallData b from _ -> Map.insertWith Set.union b (singleton from) r
_ -> r) mempty <$> access A.atomSet :: DebT m (Map BinPkgName (Set FilePath))
installedExecMap <- Set.fold (\ x r ->
case x of
A.InstallCabalExec b name _ -> Map.insertWith Set.union b (singleton name) r
A.InstallCabalExecTo b name _ -> Map.insertWith Set.union b (singleton name) r
_ -> r) mempty <$> access A.atomSet :: 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.utilsPackageNameBase >>= \ name ->
case name of
Nothing -> debianName B.Utilities hc >>= \ (BinPkgName name') -> T.utilsPackageNameBase ~= Just name'
_ -> return ()
b <- debianName B.Utilities hc
let installedDataOther = Set.map (\ a -> (a, a)) $ Set.unions $ Map.elems $ Map.delete b installedDataMap
installedExecOther = Set.union insExecPkg $ Set.unions $ Map.elems $ Map.delete b installedExecMap
let utilsData = Set.difference availableData installedDataOther
utilsExec = Set.difference availableExec installedExecOther
let utilsDataMissing = Set.difference utilsData installedData
utilsExecMissing = Set.difference utilsExec installedExec
when (not (Set.null utilsData && Set.null utilsExec)) $ do
T.debianDescription b ~?= Just desc
T.rulesFragments += (pack ("build" </> ppDisplay b ++ ":: build-ghc-stamp\n"))
T.binaryArchitectures b ~?= Just (if Set.null utilsExec then All else Any)
T.binarySection b ~?= Just (MainSection "misc")
binaryPackageRelations b B.Utilities
Set.mapM_ (uncurry (T.installData b)) utilsDataMissing
Set.mapM_ (\ name -> T.installCabalExec b name "usr/bin") utilsExecMissing
where
ename i =
case A.sourceDir i of
(Nothing) -> A.execName i
(Just s) -> s </> A.execName i
expandAtoms :: Monad m => DebT m ()
expandAtoms =
do hcs <- access A.compilerFlavors >>= return . Set.toList
builddir <- access T.buildDir >>= return . fromEmpty (case hcs of
[GHC] -> singleton "dist-ghc/build"
#if MIN_VERSION_Cabal(1,21,0)
[GHCJS] -> singleton "dist-ghcjs/build"
#endif
_ -> error $ "Unexpected compiler: " ++ show hcs)
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 ("/etc/apache2/sites-available/" ++ dom) ("/etc/apache2/sites-enabled/" ++ dom)
T.installDir b log
T.file b ("/etc/apache2/sites-available" </> dom) text
expandInstallCabalExecs :: Monad m => FilePath -> DebT m ()
expandInstallCabalExecs builddir = do
hcs <- access A.compilerFlavors >>= return . Set.toList
access A.atomSet >>= List.mapM_ (doAtom hcs) . Set.toList
where
doAtom [GHC] (A.InstallCabalExec b name dest) = T.install b (builddir </> name </> name) dest
#if MIN_VERSION_Cabal(1,21,0)
doAtom [GHCJS] (A.InstallCabalExec b name dest) =
T.rulesFragments +=
(Text.unlines
[ pack ("binary-fixup" </> ppDisplay b) <> "::"
, pack ("\t(cd " <> builddir </> name <> " && find " <> name <.> "jsexe" <> " -type f) |\\\n" <>
"\t while read i; do install -Dp " <> builddir </> name </> "$$i debian" </> ppDisplay b </> makeRelative "/" dest </> "$$i; done\n") ])
#endif
doAtom _ _ = return ()
expandInstallCabalExecTo :: Monad m => FilePath -> DebT m ()
expandInstallCabalExecTo builddir = do
hcs <- access A.compilerFlavors >>= return . Set.toList
access A.atomSet >>= List.mapM_ (doAtom hcs) . Set.toList
where
doAtom [GHC] (A.InstallCabalExecTo b name dest) =
T.rulesFragments += (Text.unlines
[ pack ("binary-fixup" </> ppDisplay b) <> "::"
, "\tinstall -Dps " <> pack (builddir </> name </> name) <> " "
<> pack ("debian" </> ppDisplay b </> makeRelative "/" dest) ])
doAtom hcs (A.InstallCabalExecTo b name dest) = error $ "expandInstallCabalExecTo " ++ show hcs ++ " " ++ show (A.InstallCabalExecTo b name dest)
doAtom _ _ = return ()
expandInstallData :: Monad m => FilePath -> DebT m ()
expandInstallData dDir =
access A.atomSet >>= List.mapM_ doAtom . Set.toList
where
doAtom (A.InstallData b from dest) =
if takeFileName from == takeFileName dest
then T.install b from (dDir </> makeRelative "/" (takeDirectory dest))
else T.installTo b from (dDir </> makeRelative "/" dest)
doAtom _ = return ()
expandInstallTo :: Monad m => DebT m ()
expandInstallTo =
access A.atomSet >>= List.mapM_ doAtom . Set.toList
where
doAtom (A.InstallTo b from dest) =
T.rulesFragments += (Text.unlines [ pack ("binary-fixup" </> ppDisplay b) <> "::"
, "\tinstall -Dp " <> pack from <> " " <> pack ("debian" </> ppDisplay b </> makeRelative "/" dest) ])
doAtom _ = return ()
expandFile :: Monad m => DebT m ()
expandFile =
access A.atomSet >>= List.mapM_ doAtom . Set.toList
where
doAtom (A.File b path text) =
do let (destDir', destName') = splitFileName path
tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack text)))
tmpPath = tmpDir </> destName'
T.intermediateFiles += (tmpPath, text)
T.install b tmpPath destDir'
doAtom _ = return ()
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]