-- | Compute the debianization of a cabal package. {-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-} module Debian.Debianize.Finalize ( debianize -- , finalizeDebianization -- external use deprecated - used in test script ) where import Control.Applicative ((<$>)) 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 (toLower) import Data.Digest.Pure.MD5 (md5) import Data.Function (on) import Data.List as List (filter, intercalate, map, nub, null, unlines, maximumBy) import Data.Map as Map (delete, elems, insertWith, lookup, Map, toList) import Data.Maybe (fromMaybe, isJust, isNothing, fromJust) import Data.Monoid ((<>), mempty) import Data.Set as Set (difference, filter, fold, fromList, insert, map, null, Set, singleton, toList, union, unions) import Data.Set.Extra as Set (mapM_) import Data.Text as Text (intercalate, pack, Text, unlines, unpack) import Debian.Changes (ChangeLog(..), ChangeLogEntry(..)) 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.DebInfo (rulesSettings) import Debian.Debianize.Goodies (backupAtoms, describe, execAtoms, serverAtoms, siteAtoms, watchAtom) import Debian.Debianize.InputDebian (dataTop, dataDest, inputChangeLog) import Debian.Debianize.Monad as Monad (CabalT, liftCabal, unlessM) import Debian.Debianize.Options (compileCommandlineArgs, compileEnvironmentArgs) import Debian.Debianize.Prelude ((.?=)) import qualified Debian.Debianize.SourceDebDescription as S import Debian.Debianize.VersionSplits (DebBase(DebBase)) import Debian.Orphans () import Debian.Policy (getCurrentDebianUser, getDebhelperCompatLevel, haskellMaintainer, PackageArchitectures(Any, All), PackagePriority(Extra), parseMaintainer, parseStandardsVersion, Section(..), SourceFormat(Native3, Quilt3)) 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.Release (parseReleaseName) import Debian.Time (getCurrentLocalRFC822Time) import qualified Debian.Version as V (buildDebianVersion, DebianVersion, parseDebianVersion, epoch, version, revision) import Distribution.Compiler (CompilerFlavor(GHC)) #if MIN_VERSION_Cabal(1,22,0) import Distribution.Compiler (CompilerFlavor(GHCJS)) #endif import Distribution.Package (Dependency(..), PackageIdentifier(..), PackageName(PackageName)) import Distribution.PackageDescription as Cabal (allBuildInfo, author, BuildInfo(buildable, extraLibs), Executable(buildInfo, exeName), FlagName(FlagName), maintainer, PackageDescription(testSuites)) import qualified Distribution.PackageDescription as Cabal (PackageDescription(dataFiles, executables, library, package)) import Prelude hiding (init, log, map, unlines, unlines, writeFile) import System.FilePath ((<.>), (), makeRelative, splitFileName, takeDirectory, takeFileName) import Text.ParserCombinators.Parsec.Rfc2822 (NameAddr(..)) import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) -- | @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, Functor m) => CabalT m () -> CabalT m () debianize customize = do compileEnvironmentArgs compileCommandlineArgs liftCabal inputChangeLog customize finalizeDebianization -- | Do some light IO and call finalizeDebianization. finalizeDebianization :: (MonadIO m, Functor m) => CabalT m () finalizeDebianization = do date <- liftIO getCurrentLocalRFC822Time debhelperCompat <- liftIO getDebhelperCompatLevel finalizeDebianization' date debhelperCompat vb <- use (A.debInfo . D.flags . verbosity) when (vb >= 3) (get >>= \ x -> liftIO (putStrLn ("\nFinalized Cabal Info: " ++ show x ++ "\n"))) -- | 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, Functor m) => String -> Maybe Int -> CabalT m () finalizeDebianization' date debhelperCompat = 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 testsEnabled <- use (A.debInfo . D.enableTests) let testsExist = not $ List.null $ Cabal.testSuites pkgDesc when (testsExist && testsEnabled) $ do (A.debInfo . rulesSettings) %= (++ ["DEB_ENABLE_TESTS = yes"]) unlessM (use (A.debInfo . D.runTests)) $ (A.debInfo . D.rulesSettings) %= (++ ["DEB_BUILD_OPTIONS += nocheck"]) 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 Extra (A.debInfo . D.sourceFormat) .?= Just Quilt3 (A.debInfo . D.compat) .?= debhelperCompat finalizeChangelog date finalizeControl finalizeRules -- T.license .?= Just (Cabal.license pkgDesc) expandAtoms -- 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 -- Turn atoms related to priority, section, and description into debianization elements -- finalizeDescriptions -- | 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, Functor 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 Just Native3 -> y _ -> maybe (Just "1") (Just . max "1") y versionArg <- use (A.debInfo . D.debVersion) -- from the --deb-version option (debianVersion :: 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 debianVersion -> case (V.epoch (fromJust debianVersion), V.parseDebianVersion (V.version (fromJust debianVersion)), V.revision (fromJust debianVersion)) of (debianEpoch, debianVersion', (debianRevision :: Maybe String)) -> let finalEpoch = max debianEpoch 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, Functor m) => B.PackageType -> CabalT m () finalizeSourceName typ = do DebBase debName <- debianNameBase (A.debInfo . D.sourcePackageName) .?= Just (SrcPkgName (case typ of B.HaskellSource -> "haskell-" ++ 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@ -- -- finalizeMaintainer :: MonadIO m => CabalT m () finalizeMaintainer = do o <- use (A.debInfo . D.official) currentUser <- liftIO getCurrentDebianUser pkgDesc <- use A.packageDescription maintainerOption <- use (A.debInfo . D.maintainerOption) uploadersOption <- use (A.debInfo . D.uploadersOption) let cabalAuthorString = takeWhile (\ c -> c /= ',' && c /= '\n') (Cabal.author pkgDesc) cabalMaintainerString = takeWhile (\ c -> c /= ',' && c /= '\n') (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) .= Just haskellMaintainer (A.debInfo . D.control . S.uploaders) %= whenEmpty (maybe [] (: []) currentUser) False -> do (A.debInfo . D.control . S.maintainer) .?= maintainerOption (A.debInfo . D.control . S.maintainer) .?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString) (A.debInfo . D.control . S.maintainer) .?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString') (A.debInfo . D.control . S.maintainer) .?= (either (const Nothing) Just $ parseMaintainer cabalMaintainerString'') -- Sometimes the maintainer is just an email, if it matches the author's email we can use it (A.debInfo . D.control . S.maintainer) .?= (case parseMaintainer cabalAuthorString of Right x | nameAddr_addr x == cabalMaintainerString -> Just x _ -> Nothing) -- Sometimes the maintainer is just an email, try combining it with the author's name (A.debInfo . D.control . S.maintainer) .?= (case parseMaintainer cabalAuthorString of Right (NameAddr {nameAddr_name = Just name}) -> either (const Nothing) Just (parseMaintainer (name ++ " <" ++ cabalMaintainerString ++ ">")) _ -> Nothing) (A.debInfo . D.control . S.maintainer) .?= currentUser (A.debInfo . D.control . S.maintainer) .?= changelogSignature x <- use (A.debInfo . D.control . S.maintainer) when (isNothing x) (do liftIO $ putStrLn ("Unable to construct a debian maintainer, using nobody . Cabal maintainer strings tried:\n " ++ show cabalMaintainerString ++ ", " ++ show cabalMaintainerString' ++ ", " ++ show cabalMaintainerString'' ++ ", currentUser: " ++ show currentUser) return ()) (A.debInfo . D.control . S.maintainer) .?= (either (const Nothing) Just $ parseMaintainer "nobody ") (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 :: (MonadIO m, Functor m) => CabalT m () finalizeControl = do finalizeMaintainer 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 }) -- | 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 :: (MonadIO m, Functor m) => String -> CabalT m () finalizeChangelog date = do finalizeMaintainer ver <- debianVersion src <- use (A.debInfo . D.sourcePackageName) Just debianMaintainer <- use (A.debInfo . D.control . S.maintainer) -- 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 (Closes: #nnnn)" (A.debInfo . D.changelog) %= fixLog src ver cmts debianMaintainer msg where fixLog :: Maybe SrcPkgName -> V.DebianVersion -> Maybe [[Text]] -> 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 (pPrint (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 (pPrint (PP src)) , logVersion = ver , logDists = [parseReleaseName "UNRELEASED"] , logUrgency = "low" , logComments = List.unlines $ List.map ((" * " <>) . List.intercalate "\n " . List.map unpack) (fromMaybe [[msg]] cmts) , logWho = 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, Functor 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, Functor 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, Functor m) => CabalT m () officialSettings = do pkgDesc <- use A.packageDescription let PackageName cabal = pkgName (Cabal.package pkgDesc) (A.debInfo . D.control . S.standardsVersion) .?= Just (parseStandardsVersion "3.9.6") (A.debInfo . D.control . S.homepage) .?= Just ("http://hackage.haskell.org/package/" <> pack cabal) (A.debInfo . D.omitProfVersionDeps) .= True SrcPkgName src <- use (A.debInfo . D.sourcePackageName) >>= maybe (error "officialSettings: no sourcePackageName") return (A.debInfo . D.control . S.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) => (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 = do edds <- use (A.debInfo . D.extraDevDeps) (A.debInfo . D.binaryDebDescription b . B.relations . B.depends) %= \ rels -> [anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++ [anyrel "${shlibs:Depends}" | typ `notElem` [B.Profiling, B.Documentation] ] ++ edds ++ rels (A.debInfo . D.binaryDebDescription b . B.relations . B.recommends) %= \ rels -> [anyrel "${haskell:Recommends}"] ++ rels (A.debInfo . D.binaryDebDescription b . B.relations . B.suggests) %= \ rels -> [anyrel "${haskell:Suggests}"] ++ rels (A.debInfo . D.binaryDebDescription b . B.relations . B.preDepends) .= [] (A.debInfo . D.binaryDebDescription b . B.relations . B.breaks) .= [] (A.debInfo . D.binaryDebDescription b . B.relations . B.conflicts) %= \ rels -> [anyrel "${haskell:Conflicts}"] ++ rels (A.debInfo . D.binaryDebDescription b . B.relations . B.provides) %= \ rels -> (if typ /= B.Documentation then [anyrel "${haskell:Provides}"] else []) ++ rels -- T.replaces b %= \ rels -> [anyrel "${haskell:Replaces}"] ++ rels (A.debInfo . D.binaryDebDescription b . B.relations . B.builtUsing) .= [] -- | Add the library paragraphs for a particular compiler flavor. librarySpecs :: (Monad m, Functor 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, Functor 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, Functor 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. (MonadIO m, Functor 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.map (\ a -> (a, a)) $ Set.unions (Map.elems installedDataMap) 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.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 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 Set.mapM_ (\ (foo, bar) -> (A.debInfo . D.atomSet) %= (Set.insert $ D.InstallData b foo bar)) utilsDataMissing Set.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 :: MonadIO m => CabalT m () expandAtoms = do hc <- use (A.debInfo . D.flags . compilerFlavor) case hc of GHC -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghc"))) #if MIN_VERSION_Cabal(1,22,0) GHCJS -> (A.debInfo . D.flags . cabalFlagAssignments) %= (Set.union (Set.fromList (flagList "--ghcjs"))) #endif x -> error $ "Sorry, compiler not supported: " ++ show x builddir <- use (A.debInfo . D.buildDir) >>= return . fromMaybe (case hc of GHC -> "dist-ghc/build" #if MIN_VERSION_Cabal(1,22,0) GHCJS -> "dist-ghcjs/build" #endif _ -> error $ "Unexpected compiler: " ++ show hc) dDest <- dataDest expandApacheSites expandInstallCabalExecs builddir expandInstallCabalExecTo builddir expandInstallData dDest expandInstallTo expandFile expandWebsite expandServer expandBackups 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) >>= Set.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) #if MIN_VERSION_Cabal(1,22,0) -- 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 " <> name <.> "jsexe" <> " -type f) |\\\n" <> "\t while read i; do install -Dp " <> builddir name "$$i debian" ppShow b makeRelative "/" dest "$$i; done\n") ]) #endif 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) >>= Set.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 () expandWebsite :: Monad m => CabalT m () expandWebsite = do mp <- get >>= return . view (A.debInfo . D.website) List.mapM_ (\ (b, site) -> modify (siteAtoms b site)) (Map.toList mp) expandServer :: Monad m => CabalT m () expandServer = do mp <- get >>= return . view (A.debInfo . D.serverInfo) List.mapM_ (\ (b, x) -> modify (serverAtoms b x False)) (Map.toList mp) expandBackups :: Monad m => CabalT m () expandBackups = do mp <- get >>= return . view (A.debInfo . D.backups) List.mapM_ (\ (b, name) -> modify (backupAtoms b name)) (Map.toList mp) 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 :: (Monad m, Functor m) => CabalT m () finalizeRules = do DebBase b <- debianNameBase compiler <- use (A.debInfo . D.flags . compilerFlavor) (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 (List.map toLower (show compiler))])) flags <- (flagString . Set.toList) <$> use (A.debInfo . D.flags . cabalFlagAssignments) unless (List.null flags) ((A.debInfo . D.rulesSettings) %= (++ ["DEB_SETUP_GHC6_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) = (FlagName (List.map toLower name), False) tagWithValue name = (FlagName (List.map toLower name), True) flagString :: [(FlagName, Bool)] -> String flagString = List.intercalate " " . List.map (\ (FlagName s, sense) -> "-f" ++ (if sense then "" else "-") ++ s)