cabal-debian-5.2: src/Debian/Debianize/Finalize.hs
-- | Compute the debianization of a cabal package.
{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}
module Debian.Debianize.Finalize
( debianize
, debianizeWith
, debianizeWebsite
-- , finalizeDebianization -- external use deprecated - used in test script
, watchAtom
) where
import Control.Lens hiding ((<.>))
import Control.Monad (unless, 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 (isSpace, toLower)
import Data.Digest.Pure.MD5 (md5)
import Data.Function (on)
import Data.List as List (dropWhileEnd, filter, intercalate, map, nub, null, unlines, maximumBy)
import Data.Map as Map (delete, elems, insertWith, lookup, Map, toList)
import Data.Maybe (fromMaybe, isJust, fromJust)
import Data.Set as Set (difference, filter, fold, fromList, insert, map, null, Set, singleton, toList, union, unions)
import Data.Text as Text (intercalate, pack, Text, unlines, unpack)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Codename (parseCodename)
import Debian.Debianize.BasicInfo (cabalFlagAssignments, compilerFlavor, verbosity)
import qualified Debian.Debianize.BinaryDebDescription as B
import Debian.Debianize.BuildDependencies (debianBuildDeps, debianBuildDepsIndep)
import qualified Debian.Debianize.CabalInfo as A
import Debian.Debianize.Changelog (dropFutureEntries)
import qualified Debian.Debianize.DebInfo as D
import Debian.Debianize.DebianName (debianName, debianNameBase)
import Debian.Debianize.ExecAtoms (execAtoms)
import Debian.Debianize.Goodies (expandWebsite, expandServer, expandBackups)
import Debian.Debianize.InputDebian (dataTop, dataDest, inputChangeLog)
import Debian.Debianize.Monad as Monad (CabalT, liftCabal)
import Debian.Debianize.Prelude ((.?=), stripWith)
import qualified Debian.Debianize.SourceDebDescription as S
import Debian.Debianize.VersionSplits (DebBase(DebBase))
import Debian.GHC (compilerPackageName)
import Debian.Orphans ()
import Debian.Policy (getCurrentDebianUser, getDebhelperCompatLevel, haskellMaintainer, maintainerOfLastResort, PackageArchitectures(Any, All), PackagePriority(Optional), parseMaintainer, parseStandardsVersion, Section(..), SourceFormat(Native3))
import Debian.Pretty (PP(..), ppShow)
import Debian.Relation (BinPkgName, BinPkgName(BinPkgName), Relation(Rel), Relations, SrcPkgName(SrcPkgName))
import qualified Debian.Relation as D (BinPkgName(BinPkgName), Relation(..))
import Debian.Time (getCurrentLocalRFC822Time)
import qualified Debian.Version as V (buildDebianVersion, DebianVersion, parseDebianVersion', epoch, version, revision)
import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.Compiler (CompilerFlavor(GHCJS))
import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName, unPackageName)
import Distribution.PackageDescription as Cabal (allBuildInfo, author, BuildInfo(buildable, extraLibs), Executable(buildInfo, exeName), FlagName, mkFlagName, unFlagName, maintainer, PackageDescription(testSuites, description))
import Distribution.Types.UnqualComponentName
import Distribution.PackageDescription as Cabal (PackageDescription(dataFiles, {-description,-} executables, library, package, synopsis))
#if MIN_VERSION_Cabal(3,2,0)
import qualified Distribution.Utils.ShortText as ST
#endif
import Prelude hiding (init, log, map, unlines, unlines, writeFile)
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>), makeRelative, splitFileName, takeDirectory, takeFileName)
import System.IO (hPutStrLn, stderr)
import Text.Parsec.Rfc2822 (NameAddr(..))
import Distribution.Pretty (Pretty(pretty))
-- | @debianize customize@ initializes the CabalT state from the
-- environment and the cabal package description in (and possibly the
-- debian/changelog file) from the current directory, then runs
-- @customize@ and finalizes the debianization so it is ready to be
-- output.
debianize :: (MonadIO m, MonadFail m) => CabalT m () -> CabalT m ()
debianize = debianizeWith (return ())
debianizeWebsite :: (MonadIO m, MonadFail m) => CabalT m () -> CabalT m ()
debianizeWebsite = debianizeWith (expandWebsite >> expandServer >> expandBackups)
-- | Pass a function with some additional work to do. I don't know
-- if this could be done by just summing it with customize - probably.
-- But I don't want to untangle this right now.
debianizeWith :: (MonadIO m, MonadFail m) => CabalT m () -> CabalT m () -> CabalT m ()
debianizeWith goodies customize =
do liftCabal inputChangeLog
customize
finalizeDebianization goodies
-- | Do some light IO and call finalizeDebianization.
finalizeDebianization :: (MonadIO m, MonadFail m) => CabalT m () -> CabalT m ()
finalizeDebianization goodies =
do date <- liftIO getCurrentLocalRFC822Time
currentUser <- liftIO getCurrentDebianUser
debhelperCompat <- liftIO getDebhelperCompatLevel
setupExists <- or <$> mapM (liftIO . doesFileExist) ["Setup.hs", "Setup.lhs"]
finalizeDebianization' goodies date currentUser debhelperCompat setupExists
vb <- use (A.debInfo . D.flags . verbosity)
when (vb >= 3) (get >>= \ x -> liftIO (putStrLn ("\nFinalized Cabal Info: " ++ show x ++ "\n")))
either (\e -> liftIO $ hPutStrLn stderr ("WARNING: " ++ e)) (\_ -> return ()) =<< use (A.debInfo . D.control . S.maintainer)
-- | Now that we know the build and data directories, we can expand
-- some atoms into sets of simpler atoms which can eventually be
-- turned into the files of the debianization. The original atoms are
-- not removed from the list because they may contribute to the
-- debianization in other ways, so be careful not to do this twice,
-- this function is not idempotent. (Exported for use in unit tests.)
-- FIXME: we should be able to run this without a PackageDescription, change
-- paramter type to Maybe PackageDescription and propagate down thru code
finalizeDebianization' ::
(MonadIO m, MonadFail m)
=> CabalT m ()
-> String
-> Maybe NameAddr
-> Maybe Int
-> Bool
-> CabalT m ()
finalizeDebianization' goodies date currentUser debhelperCompat setupExists =
do -- In reality, hcs must be a singleton or many things won't work. But some day...
hc <- use (A.debInfo . D.flags . compilerFlavor)
pkgDesc <- use A.packageDescription
testsStatus <- use (A.debInfo . D.testsStatus)
let testsExist = not $ List.null $ Cabal.testSuites pkgDesc
case (testsExist, testsStatus) of
(True, D.TestsRun) -> (A.debInfo . D.rulesSettings) %= (++ ["DEB_ENABLE_TESTS = yes"])
(True, D.TestsBuild) -> (A.debInfo . D.rulesSettings) %= (++ ["DEB_ENABLE_TESTS = yes", "DEB_BUILD_OPTIONS += nocheck"])
_ -> return ()
(A.debInfo . D.rulesSettings) %=
(++ ["DEB_SETUP_BIN_NAME = " <> if setupExists then "debian/hlibrary.setup" else "cabal"])
finalizeSourceName B.HaskellSource
checkOfficialSettings hc
addExtraLibDependencies hc
(A.debInfo . D.watch) .?= Just (watchAtom (pkgName $ Cabal.package $ pkgDesc))
(A.debInfo . D.control . S.section) .?= Just (MainSection "haskell")
(A.debInfo . D.control . S.priority) .?= Just Optional
(A.debInfo . D.compat) .?= debhelperCompat
finalizeChangelog date currentUser
finalizeControl currentUser
finalizeRules
-- T.license .?= Just (Cabal.license pkgDesc)
expandAtoms goodies
-- Create the binary packages for the web sites, servers, backup packges, and other executables
use (A.debInfo . D.executable) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
use (A.debInfo . D.backups) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
use (A.debInfo . D.serverInfo) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
use (A.debInfo . D.website) >>= List.mapM_ (cabalExecBinaryPackage . fst) . Map.toList
-- Make sure all the control file sections exist before doing the build dependencies,
-- because we need to filter out self dependencies.
librarySpecs pkgDesc hc
makeUtilsPackage pkgDesc hc
debs <- use (A.debInfo . D.control . S.binaryPackages) >>= return . List.map (view B.package)
allowSelfDeps <- use (A.debInfo . D.allowDebianSelfBuildDeps)
putBuildDeps (if allowSelfDeps then id else filterRelations debs) pkgDesc
-- Sketchy - I think more things that need expanded could be generated by the code
-- executed since the last expandAtoms. Anyway, should be idempotent.
expandAtoms goodies
-- Turn atoms related to priority, section, and description into debianization elements
-- finalizeDescriptions
watchAtom :: PackageName -> Text
watchAtom pkgname =
pack $ "version=3\nhttps://hackage.haskell.org/package/" ++ unPackageName pkgname ++ "/distro-monitor .*-([0-9\\.]+)\\.(?:zip|tgz|tbz|txz|(?:tar\\.(?:gz|bz2|xz)))\n"
-- | Compute the final values of the BinaryDebDescription record
-- description fields from the cabal descriptions and the values that
-- have already been set.
{-
finalizeDescriptions :: (Monad m, Functor m) => CabalT m ()
finalizeDescriptions = use T.binaryPackages >>= List.mapM_ finalizeDescription
finalizeDescription :: (Monad m, Functor m) => B.BinaryDebDescription -> CabalT m ()
finalizeDescription bdd =
do let b = view B.package bdd
cabDesc <- describe
T.debianDescription .?= Just cabDesc
-}
-- | Construct the final Debian version number.
-- Inputs:
--
-- 1. --deb-version argument
-- 2. --revision argument
-- 3. cabal version number
-- 4. latest version in debian/changelog
--
-- The --deb-version argument overrides everything.
debianVersion :: (Monad m) => CabalT m V.DebianVersion
debianVersion =
do cabalName <- (pkgName . Cabal.package) <$> use A.packageDescription
(cabalVersion :: V.DebianVersion) <- (V.parseDebianVersion' . ppShow . pkgVersion . Cabal.package) <$> use A.packageDescription
cabalEpoch <- debianEpoch cabalName
fmt <- use (A.debInfo . D.sourceFormat)
cabalRevision <-
do x <- use (A.debInfo . D.revision) -- from the --revision option
let y = case x of
Nothing -> Nothing
Just "" -> Nothing
Just "-" -> Nothing
Just ('-':r) -> Just r
Just _ -> error "The --revision argument must start with a dash"
return $ case fmt of
Native3 -> y
_ -> maybe (Just "1") (Just . max "1") y
versionArg <- use (A.debInfo . D.debVersion) -- from the --deb-version option
(debVersion :: Maybe V.DebianVersion) <- use (A.debInfo . D.changelog) >>= return . maybe Nothing changelogVersion
case () of
_ | maybe False (\ v -> v < V.buildDebianVersion cabalEpoch (ppShow cabalVersion) Nothing) versionArg ->
error ("Version from --deb-version (" ++ ppShow versionArg ++
") is older than cabal version (" ++ ppShow cabalVersion ++
"), maybe you need to unpin this package?")
_ | isJust versionArg -> return $ fromJust versionArg
_ | isJust debVersion ->
case (V.epoch (fromJust debVersion),
V.parseDebianVersion' (V.version (fromJust debVersion)),
V.revision (fromJust debVersion)) of
(debEpoch, debianVersion', (debianRevision :: Maybe String)) ->
let finalEpoch = max debEpoch cabalEpoch
finalVersion = max debianVersion' cabalVersion
(finalRevision :: Maybe String) = maximumBy (compare `on` fmap V.parseDebianVersion') [debianRevision, cabalRevision] in
return $ V.buildDebianVersion finalEpoch (ppShow finalVersion) finalRevision
_ -> return $ V.buildDebianVersion cabalEpoch (ppShow cabalVersion) cabalRevision
changelogVersion :: ChangeLog -> Maybe V.DebianVersion
changelogVersion (ChangeLog (Entry {logVersion = x} : _)) = Just x
changelogVersion _ = Nothing
-- | Return the Debian epoch number assigned to the given cabal
-- package - the 1 in version numbers like 1:3.5-2.
debianEpoch :: Monad m => PackageName -> CabalT m (Maybe Int)
debianEpoch name = get >>= return . Map.lookup name . view A.epochMap
-- | Compute and return the debian source package name, based on the
-- sourcePackageName if it was specified, and constructed from the
-- cabal name otherwise.
finalizeSourceName :: (Monad m) => B.PackageType -> CabalT m ()
finalizeSourceName typ =
do DebBase debName <- debianNameBase
hc <- use (A.debInfo . D.flags . compilerFlavor)
(A.debInfo . D.sourcePackageName) .?=
Just (SrcPkgName (case (hc, typ) of
-- Haskell source deb names conventionally have the prefix
-- "haskell-" added. Here we add prefix "ghcjs-" to
-- haskell packages build with the ghcjs compiler.
(GHC, B.HaskellSource) -> "haskell-" ++ debName
(GHCJS, B.HaskellSource) -> "ghcjs-" ++ debName
(_, B.Source) -> debName
_ -> error $ "finalizeSourceName: " ++ show typ))
-- | Try to compute a string for the the debian "Maintainer:" and
-- "Uploaders:" fields using, in this order
-- 1. the Debian Haskell Group, @pkg-haskell-maintainers\@lists.alioth.debian.org@,
-- if --official is set
-- 2. the maintainer explicitly specified using "Debian.Debianize.Monad.maintainer"
-- 3. the maintainer field of the cabal package, but only if --official is not set,
-- 4. the value returned by getDebianMaintainer, which looks in several environment variables,
-- 5. the signature from the latest entry in debian/changelog,
-- 6. the Debian Haskell Group, @pkg-haskell-maintainers\@lists.alioth.debian.org@
-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Maintainer>
-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Uploaders>
finalizeMaintainer :: Monad m => Maybe NameAddr -> CabalT m ()
finalizeMaintainer currentUser = do
o <- use (A.debInfo . D.official)
pkgDesc <- use A.packageDescription
maintainerOption <- use (A.debInfo . D.maintainerOption)
uploadersOption <- use (A.debInfo . D.uploadersOption)
#if MIN_VERSION_Cabal(3,2,0)
let toString = ST.fromShortText
#else
let toString = id
#endif
cabalAuthorString = takeWhile (\ c -> c /= ',' && c /= '\n') (toString (Cabal.author pkgDesc))
cabalMaintainerString = takeWhile (\ c -> c /= ',' && c /= '\n') (toString (Cabal.maintainer pkgDesc))
cabalMaintainerString' = cabalAuthorString <> " <" <> cabalMaintainerString <> ">"
cabalMaintainerString'' = cabalAuthorString <> " " <> cabalMaintainerString
changelogSignature <-
do log <- use (A.debInfo . D.changelog)
case log of
Just (ChangeLog (entry : _)) ->
case (parseMaintainer (logWho entry)) of
Left _e -> return $ Nothing -- Just $ NameAddr (Just "Invalid signature in changelog") (show e)
Right x -> return (Just x)
_ -> return Nothing
case o of
True -> do
(A.debInfo . D.control . S.maintainer) .= Right haskellMaintainer
(A.debInfo . D.control . S.uploaders) %= whenEmpty (maybe [] (: []) currentUser)
False -> do
(A.debInfo . D.control . S.maintainer) %= either (\x -> maybe (Left x) Right maintainerOption) Right
(A.debInfo . D.control . S.maintainer) %= either (\_ -> parseMaintainer cabalMaintainerString) Right
(A.debInfo . D.control . S.maintainer) %= either (\_ -> parseMaintainer cabalMaintainerString') Right
(A.debInfo . D.control . S.maintainer) %= either (\_ -> parseMaintainer cabalMaintainerString'') Right
-- Sometimes the maintainer is just an email, if it matches the author's email we can use it
(A.debInfo . D.control . S.maintainer) %= either (\e -> case parseMaintainer cabalAuthorString of
Right x | nameAddr_addr x == cabalMaintainerString -> Right x
Right _ -> Left e
Left x -> Left x) Right
-- Sometimes the maintainer is just an email, try combining it with the author's name
(A.debInfo . D.control . S.maintainer) %= either (\e -> case parseMaintainer cabalAuthorString of
Right (NameAddr {nameAddr_name = Just name}) -> parseMaintainer (name ++ " <" ++ cabalMaintainerString ++ ">")
Right _ -> Left e
Left x -> Left x) Right
(A.debInfo . D.control . S.maintainer) %= either (\e -> maybe (Left e) Right currentUser) Right
(A.debInfo . D.control . S.maintainer) %= either (\e -> maybe (Left e) Right changelogSignature) Right
(A.debInfo . D.control . S.maintainer) %= either (\_ -> Left ("Unable to construct a debian maintainer, using default. Cabal maintainer strings tried:\n " ++
show cabalMaintainerString ++ ", " ++ show cabalMaintainerString' ++ ", " ++ show cabalMaintainerString'' ++
", currentUser: " ++ show currentUser)) Right
(A.debInfo . D.control . S.uploaders) %= whenEmpty uploadersOption
-- | If l is the empty list return d, otherwise return l.
whenEmpty :: [a] -> [a] -> [a]
whenEmpty d [] = d
whenEmpty _ l = l
finalizeControl :: (MonadFail m) => Maybe NameAddr -> CabalT m ()
finalizeControl currentUser =
do finalizeMaintainer currentUser
Just src <- use (A.debInfo . D.sourcePackageName)
(A.debInfo . D.control . S.source) .= Just src
desc' <- describe
(A.debInfo . D.control . S.xDescription) .?= Just desc'
-- control %= (\ y -> y { D.source = Just src, D.maintainer = Just maint })
describe :: Monad m => CabalT m Text
describe =
do p <- use A.packageDescription
return $
debianDescriptionBase p {- <> "\n" <>
case typ of
Just B.Profiling ->
Text.intercalate "\n"
[" .",
" This package provides a library for the Haskell programming language, compiled",
" for profiling. See http:///www.haskell.org/ for more information on Haskell."]
Just B.Development ->
Text.intercalate "\n"
[" .",
" This package provides a library for the Haskell programming language.",
" See http:///www.haskell.org/ for more information on Haskell."]
Just B.Documentation ->
Text.intercalate "\n"
[" .",
" This package provides the documentation for a library for the Haskell",
" programming language.",
" See http:///www.haskell.org/ for more information on Haskell." ]
Just B.Exec ->
Text.intercalate "\n"
[" .",
" An executable built from the " <> pack (display (pkgName (Cabal.package p))) <> " package."]
{- ServerPackage ->
Text.intercalate "\n"
[" .",
" A server built from the " <> pack (display (pkgName pkgId)) <> " package."] -}
_ {-Utilities-} ->
Text.intercalate "\n"
[" .",
" Files associated with the " <> pack (display (pkgName (Cabal.package p))) <> " package."]
-- x -> error $ "Unexpected library package name suffix: " ++ show x
-}
-- | The Cabal package has one synopsis and one description field
-- for the entire package, while in a Debian package there is a
-- description field (of which the first line is synopsis) in
-- each binary package. So the cabal description forms the base
-- of the debian description, each of which is amended.
debianDescriptionBase :: PackageDescription -> Text
debianDescriptionBase p =
pack $ List.intercalate "\n " $ (synop' : desc')
where
-- If we have a one line description and no synopsis, use
-- the description as the synopsis.
synop' = if List.null synop && length desc' /= 1
then "WARNING: No synopsis available for package " ++ ppShow (package p)
else synop
synop :: String
-- I don't know why (unwords . words) was applied here. Maybe I'll find out when
-- this version goes into production. :-/ Ok, now I know, because sometimes the
-- short cabal description has more than one line.
synop = List.intercalate " " $ fmap (dropWhileEnd isSpace) $ lines $ toString $ synopsis p
desc' :: [String]
desc' = List.map addDot . stripWith List.null $ fmap (dropWhileEnd isSpace) $ lines $ toString $ Cabal.description p
addDot line = if List.null line then "." else line
#if MIN_VERSION_Cabal(3,2,0)
toString = ST.fromShortText
#else
toString = id
#endif
-- | Make sure there is a changelog entry with the version number and
-- source package name implied by the debianization. This means
-- either adding an entry or modifying the latest entry (if its
-- version number is the exact one in our debianization.)
finalizeChangelog :: (Monad m) => String -> Maybe NameAddr -> CabalT m ()
finalizeChangelog date currentUser =
do finalizeMaintainer currentUser
ver <- debianVersion
src <- use (A.debInfo . D.sourcePackageName)
debianUploaders <- use (A.debInfo . D.control . S.uploaders)
debianMaintainer <- use (A.debInfo . D.control . S.maintainer)
let nameToUse | (n:_) <- debianUploaders = Right n
| otherwise = debianMaintainer
-- pkgDesc <- use T.packageDescription >>= return . maybe Nothing (either Nothing Just . parseMaintainer . Cabal.maintainer)
cmts <- use (A.debInfo . D.comments)
(A.debInfo . D.changelog) %= fmap (dropFutureEntries ver)
let msg = "Initial release"
(A.debInfo . D.changelog) %= fixLog src ver cmts nameToUse msg
where
fixLog :: Maybe SrcPkgName -> V.DebianVersion -> Maybe [[Text]] -> Either String NameAddr -> Text -> Maybe ChangeLog -> Maybe ChangeLog
-- Ensure that the package name is correct in the first log entry.
fixLog src ver cmts _maint _ (Just (ChangeLog (entry : older)))
| logVersion entry == ver =
let entry' = entry { logPackage = show (pretty (PP src))
, logComments = logComments entry ++ "\n" ++
(List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) (fromMaybe [] cmts))
} in
Just (ChangeLog (entry' : older))
-- The newest log entry isn't exactly ver, build a new entry.
fixLog src ver cmts maint msg log =
let entry = Entry { logPackage = show (pretty (PP src))
, logVersion = ver
, logDists = [parseCodename "UNRELEASED"]
, logUrgency = "low"
, logComments =
List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) (fromMaybe [[msg]] cmts)
, logWho = either (\_ -> ppShow maintainerOfLastResort) ppShow maint
, logDate = date } in
-- Creating new log entry for version
Just (ChangeLog (entry : maybe [] (\ (ChangeLog entries) -> entries) log))
-- | Convert the extraLibs field of the cabal build info into debian
-- binary package names and make them dependendencies of the debian
-- devel package (if there is one.)
addExtraLibDependencies :: (Monad m) => CompilerFlavor -> CabalT m ()
addExtraLibDependencies hc =
do pkgDesc <- use A.packageDescription
devName <- debianName B.Development hc
libMap <- use (A.debInfo . D.extraLibMap)
binNames <- List.map (view B.package) <$> use (A.debInfo . D.control . S.binaryPackages)
when (any (== devName) binNames) ((A.debInfo . D.binaryDebDescription devName . B.relations . B.depends) %= \ 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)
-- | Applies a few settings to official packages (unless already set)
checkOfficialSettings :: (Monad m) => CompilerFlavor -> CabalT m ()
checkOfficialSettings flavor =
do o <- use (A.debInfo . D.official)
when o $ case flavor of
GHC -> officialSettings
_ -> error $ "There is no official packaging for " ++ show flavor
officialSettings :: (Monad m) => CabalT m ()
officialSettings = do
pkgDesc <- use A.packageDescription
let cabal = pkgName (Cabal.package pkgDesc)
zoom A.debInfo $ do
let officialError = error "officialSettings: no sourcePackageName"
D.omitProfVersionDeps .= True
SrcPkgName src <- fromMaybe officialError <$> use D.sourcePackageName
let packagesURI = "https://salsa.debian.org/haskell-team/DHG_packages/tree/master/p/" <> pack src
zoom D.control $ do
S.standardsVersion .?= Just (parseStandardsVersion "4.6.1")
S.homepage .?= Just ("https://hackage.haskell.org/package/" <> pack (unPackageName cabal))
S.vcsFields %= Set.union (Set.fromList
[ S.VCSBrowser packagesURI
, S.VCSGit "https://salsa.debian.org/haskell-team/DHG_packages.git"
])
putBuildDeps :: (MonadIO m) => (Relations -> Relations) -> PackageDescription -> CabalT m ()
putBuildDeps finalizeRelations pkgDesc =
do deps <- debianBuildDeps pkgDesc >>= return . finalizeRelations
depsIndep <- debianBuildDepsIndep pkgDesc >>= return . finalizeRelations
(A.debInfo . D.control . S.buildDepends) .= deps
(A.debInfo . D.control . S.buildDependsIndep) .= depsIndep
-- | Filter out any relations that mention any of the bad package names.
filterRelations :: [BinPkgName] -> Relations -> Relations
filterRelations badNames orRels =
List.filter (not . List.null) (List.map filterOrRelation orRels)
where
filterOrRelation :: [Relation] -> [Relation]
filterOrRelation rels = List.filter (\ (Rel name _ _) -> not (elem name badNames)) rels
cabalExecBinaryPackage :: Monad m => BinPkgName -> CabalT m ()
cabalExecBinaryPackage b =
do (A.debInfo . D.binaryDebDescription b . B.packageType) .?= Just B.Exec
(A.debInfo . D.binaryDebDescription b . B.architecture) .?= Just Any
(A.debInfo . D.binaryDebDescription b . B.binarySection) .?= Just (MainSection "misc")
(A.debInfo . D.binaryDebDescription b . B.description) .?= Just desc -- yeah, this same line is all over the place.
binaryPackageRelations b B.Exec
where
binaryPackageRelations :: Monad m => BinPkgName -> B.PackageType -> CabalT m ()
binaryPackageRelations b typ = zoom A.debInfo $ do
edds <- use D.extraDevDeps
zoom (D.binaryDebDescription b . B.relations) $ do
when (typ == B.Development) $ do
B.depends %= (edds ++)
B.depends %= (anyrel "${shlibs:Depends}" : )
when (typ == B.Utilities) $
B.depends %= (anyrel "${shlibs:Depends}" : )
B.depends %= ([anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++)
B.recommends %= (anyrel "${haskell:Recommends}" : )
B.suggests %= (anyrel "${haskell:Suggests}" :)
B.conflicts %= (anyrel "${haskell:Conflicts}" :)
B.preDepends .= []
B.breaks .= []
B.builtUsing .= []
unless (typ == B.Documentation) $ B.provides %= (anyrel "${haskell:Provides}" :)
-- | Add the library paragraphs for a particular compiler flavor.
librarySpecs :: (Monad m) => PackageDescription -> CompilerFlavor -> CabalT m ()
librarySpecs pkgDesc hc =
do let dev = isJust (Cabal.library pkgDesc)
doc <- get >>= return . not . view (A.debInfo . D.noDocumentationLibrary)
prof <- get >>= return . not . view (A.debInfo . D.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) => CompilerFlavor -> CabalT m ()
docSpecsParagraph hc =
do b <- debianName B.Documentation hc
binaryPackageRelations b B.Documentation
(A.debInfo . D.binaryDebDescription b . B.packageType) .?= Just B.Documentation
(A.debInfo . D.binaryDebDescription b . B.packageType) .?= Just B.Documentation
(A.debInfo . D.binaryDebDescription b . B.architecture) .= Just All
(A.debInfo . D.binaryDebDescription b . B.binarySection) .?= Just (MainSection "doc")
(A.debInfo . D.binaryDebDescription b . B.description) .?= Just desc
librarySpec :: (Monad m) => PackageArchitectures -> B.PackageType -> CompilerFlavor -> CabalT m ()
librarySpec arch typ hc =
do b <- debianName typ hc
binaryPackageRelations b typ
(A.debInfo . D.binaryDebDescription b . B.packageType) .?= Just typ
(A.debInfo . D.binaryDebDescription b . B.packageType) .?= Just typ
(A.debInfo . D.binaryDebDescription b . B.architecture) .?= Just arch
(A.debInfo . D.binaryDebDescription b . B.description) .?= Just desc
-- | This is the standard value for the Description field of a binary
-- package control file stanza.
desc :: Text
desc = Text.intercalate "\n "
["${haskell:ShortDescription}${haskell:ShortBlurb}",
"${haskell:LongDescription}",
".",
"${haskell:Blurb}"]
-- | Make sure all data and executable files are assigned to at least
-- one binary package and make sure all binary packages are in the
-- package list in the source deb description. If there are left over
-- files, assign them to the packages returned by the
-- utilsPackageNames lens, and make sure those packages are in the
-- source deb description.
makeUtilsPackage :: forall m. (Monad m) => PackageDescription -> CompilerFlavor -> CabalT m ()
makeUtilsPackage pkgDesc hc =
do -- Files the cabal package expects to be installed
-- Files that are already assigned to any binary deb
installedDataMap <- Set.fold (\ x r ->
case x of
D.Install b src _ -> Map.insertWith Set.union b (singleton src) r
D.InstallTo b src _ -> Map.insertWith Set.union b (singleton src) r
D.InstallData b src _ -> Map.insertWith Set.union b (singleton src) r
_ -> r) mempty <$> use (A.debInfo . D.atomSet) :: CabalT m (Map BinPkgName (Set FilePath))
installedExecMap <- Set.fold (\ x r ->
case x of
D.InstallCabalExec b name _ -> Map.insertWith Set.union b (singleton name) r
D.InstallCabalExecTo b name _ -> Map.insertWith Set.union b (singleton name) r
_ -> r) mempty <$> use (A.debInfo . D.atomSet) :: CabalT m (Map BinPkgName (Set String))
-- The names of cabal executables that go into eponymous debs
insExecPkg <- use (A.debInfo . D.executable) >>= return . Set.map ename . Set.fromList . elems
let installedData :: Set (FilePath, FilePath)
installedData = Set.map (\ a -> (a, a)) $ Set.unions (Map.elems installedDataMap)
installedExec :: Set String
installedExec = Set.unions (Map.elems installedExecMap)
prefixPath <- dataTop
let dataFilePaths = Set.fromList (zip (List.map (prefixPath </>) (Cabal.dataFiles pkgDesc)) (Cabal.dataFiles pkgDesc)) :: Set (FilePath, FilePath)
execFilePaths :: Set FilePath
execFilePaths = Set.map (unUnqualComponentName . 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
use (A.debInfo . D.utilsPackageNameBase) >>= \ name ->
case name of
Nothing -> debianName B.Utilities hc >>= \ (BinPkgName name') -> (A.debInfo . D.utilsPackageNameBase) .= Just name'
_ -> return ()
b <- debianName B.Utilities hc
-- Files that are installed into packages other than the utils packages
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
-- Files that will be in utils packages
let utilsData = Set.difference availableData installedDataOther
utilsExec = Set.difference availableExec installedExecOther
-- Files that still need to be assigned to the utils packages
let utilsDataMissing = Set.difference utilsData installedData
utilsExecMissing = Set.difference utilsExec installedExec
-- If any files belong in the utils packages, make sure they exist
when (not (Set.null utilsData && Set.null utilsExec)) $ do
(A.debInfo . D.binaryDebDescription b . B.description) .?= Just desc
-- This is really for all binary debs except the libraries - I'm not sure why
(A.debInfo . D.rulesFragments) %= Set.insert (pack ("build" </> ppShow b ++ ":: build-ghc-stamp\n"))
(A.debInfo . D.binaryDebDescription b . B.architecture) .?= Just (if Set.null utilsExec then All else Any)
(A.debInfo . D.binaryDebDescription b . B.binarySection) .?= Just (MainSection "misc")
binaryPackageRelations b B.Utilities
-- Add the unassigned files to the utils packages
mapM_ (\ (foo, bar) -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing
mapM_ (\ name -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec b name "usr/bin")) utilsExecMissing
where
ename i =
case D.sourceDir i of
Nothing -> D.execName i
Just s -> s </> D.execName i
expandAtoms :: Monad m => CabalT m () -> CabalT m ()
expandAtoms goodies =
do hc <- use (A.debInfo . D.flags . compilerFlavor)
case hc of
GHC -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghc")))
GHCJS -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghcjs")))
x -> error $ "Sorry, compiler not supported: " ++ show x
builddir <- use (A.debInfo . D.buildDir) >>= return . fromMaybe (case hc of
GHC -> "dist-ghc/build"
GHCJS -> "dist-ghcjs/build"
_ -> error $ "Unexpected compiler: " ++ show hc)
dDest <- dataDest
expandApacheSites
expandInstallCabalExecs builddir
expandInstallCabalExecTo builddir
expandInstallData dDest
expandInstallTo
expandFile
#if 1
goodies
#else
expandWebsite
expandServer
expandBackups
#endif
expandExecutable
where
expandApacheSites :: Monad m => CabalT m ()
expandApacheSites =
do mp <- get >>= return . view (A.debInfo . D.apacheSite)
List.mapM_ expandApacheSite (Map.toList mp)
where
expandApacheSite (b, (dom, log, text)) =
do (A.debInfo . D.atomSet) %= (Set.insert $ D.Link b ("/etc/apache2/sites-available/" ++ dom) ("/etc/apache2/sites-enabled/" ++ dom))
(A.debInfo . D.atomSet) %= (Set.insert $ D.InstallDir b log)
(A.debInfo . D.atomSet) %= (Set.insert $ D.File b ("/etc/apache2/sites-available" </> dom) text)
-- Turn A.InstallCabalExec into A.Install
expandInstallCabalExecs :: Monad m => FilePath -> CabalT m ()
expandInstallCabalExecs builddir = do
hc <- use (A.debInfo . D.flags . compilerFlavor)
use (A.debInfo . D.atomSet) >>= mapM_ (doAtom hc)
where
doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m ()
doAtom GHC (D.InstallCabalExec b name dest) = (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b (builddir </> name </> name) dest)
-- A GHCJS executable is a directory with files, copy them
-- all into place.
doAtom GHCJS (D.InstallCabalExec b name dest) =
(A.debInfo . D.rulesFragments) %= Set.insert
(Text.unlines
[ pack ("binary-fixup" </> ppShow b) <> "::"
, pack ("\t(cd " <> builddir </> name <> " && find -L " <> name <.> "jsexe" <> " -type f) |\\\n" <>
"\t while read i; do install -Dp " <> builddir </> name </> "$$i debian" </> ppShow b </> makeRelative "/" dest </> "$$i; done\n") ])
doAtom _ _ = return ()
-- Turn A.InstallCabalExecTo into a make rule
expandInstallCabalExecTo :: Monad m => FilePath -> CabalT m ()
expandInstallCabalExecTo builddir = do
hc <- use (A.debInfo . D.flags . compilerFlavor)
use (A.debInfo . D.atomSet) >>= mapM_ (doAtom hc)
where
doAtom :: Monad m => CompilerFlavor -> D.Atom -> CabalT m ()
doAtom GHC (D.InstallCabalExecTo b name dest) =
(A.debInfo . D.rulesFragments) %= Set.insert
(Text.unlines
[ pack ("binary-fixup" </> ppShow b) <> "::"
, "\tinstall -Dps " <> pack (builddir </> name </> name) <> " "
<> pack ("debian" </> ppShow b </> makeRelative "/" dest) ])
doAtom hc (D.InstallCabalExecTo b name dest) = error $ "expandInstallCabalExecTo " ++ show hc ++ " " ++ show (D.InstallCabalExecTo b name dest)
doAtom _ _ = return ()
-- Turn A.InstallData into either an Install or an InstallTo
expandInstallData :: Monad m => FilePath -> CabalT m ()
expandInstallData dDest =
use (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList
where
doAtom :: Monad m => D.Atom -> CabalT m ()
doAtom (D.InstallData b src dest) =
if takeFileName src == takeFileName dest
then (A.debInfo . D.atomSet) %= (Set.insert $ D.Install b src (dDest </> makeRelative "/" (takeDirectory dest)))
else (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallTo b src (dDest </> makeRelative "/" dest))
doAtom _ = return ()
-- Turn A.InstallTo into a make rule
expandInstallTo :: Monad m => CabalT m ()
expandInstallTo =
use (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList
where
doAtom :: Monad m => D.Atom -> CabalT m ()
doAtom (D.InstallTo b src dest) =
(A.debInfo . D.rulesFragments) %= Set.insert
(Text.unlines [ pack ("binary-fixup" </> ppShow b) <> "::"
, "\tinstall -Dp " <> pack src <> " " <> pack ("debian" </> ppShow b </> makeRelative "/" dest) ])
doAtom _ = return ()
-- Turn A.File into an intermediateFile and an A.Install
expandFile :: Monad m => CabalT m ()
expandFile =
use (A.debInfo . D.atomSet) >>= List.mapM_ doAtom . Set.toList
where
doAtom :: Monad m => D.Atom -> CabalT m ()
doAtom (D.File b path text) =
do let (destDir', destName') = splitFileName path
tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack text)))
tmpPath = tmpDir </> destName'
(A.debInfo . D.intermediateFiles) %= Set.insert (tmpPath, text)
(A.debInfo . D.atomSet) %= (Set.insert $ D.Install b tmpPath destDir')
doAtom _ = return ()
expandExecutable :: Monad m => CabalT m ()
expandExecutable =
do mp <- get >>= return . view (A.debInfo . D.executable)
List.mapM_ (\ (b, f) -> modify (execAtoms b f)) (Map.toList mp)
-- | Add the normal default values to the rules files.
finalizeRules :: (MonadIO m) => CabalT m ()
finalizeRules =
do DebBase b <- debianNameBase
hc <- use (A.debInfo . D.flags . compilerFlavor)
cpn <- liftIO $ compilerPackageName hc B.Development
let BinPkgName hcdeb = fromMaybe (error "No compiler package") cpn
(A.debInfo . D.rulesHead) .?= Just "#!/usr/bin/make -f"
(A.debInfo . D.rulesSettings) %= (++ ["DEB_CABAL_PACKAGE = " <> pack b])
(A.debInfo . D.rulesSettings) %= (++ ["DEB_DEFAULT_COMPILER = " <> pack hcdeb])
flags <- flagString . Set.toList <$> use (A.debInfo . D.flags . cabalFlagAssignments)
unless (List.null flags) ((A.debInfo . D.rulesSettings) %= (++ ["DEB_SETUP_GHC_CONFIGURE_ARGS = " <> pack flags]))
(A.debInfo . D.rulesIncludes) %= (++ ["include /usr/share/cdbs/1/rules/debhelper.mk",
"include /usr/share/cdbs/1/class/hlibrary.mk"])
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]
-- Lifted from Distribution.Simple.Setup, since it's not exported.
flagList :: String -> [(FlagName, Bool)]
flagList = List.map tagWithValue . words
where tagWithValue ('-':name) = (mkFlagName (List.map toLower name), False)
tagWithValue name = (mkFlagName (List.map toLower name), True)
flagString :: [(FlagName, Bool)] -> String
flagString = unwords . List.map (\ (s, sense) -> "-f" ++ (if sense then "" else "-") ++ unFlagName s)