module Debian.Debianize.Finalize
( finalizeDebianization
) where
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Char (toLower)
import Data.Digest.Pure.MD5 (md5)
import Data.Lens.Lazy (setL, getL, modL)
import Data.List as List (map)
import Data.Map as Map (insertWith, foldWithKey, elems)
import Data.Maybe
import Data.Monoid (mempty, (<>))
import Data.Set as Set (Set, difference, fromList, null, insert, toList, filter, fold, map, union, singleton)
import Data.Text as Text (pack, unlines, unpack)
import Debian.Debianize.Atoms as Atoms
(Atoms, packageDescription, control, binaryArchitectures, rulesFragments, website, serverInfo, link,
backups, executable, sourcePriority, sourceSection, binaryPriorities, binarySections, description,
install, installTo, installData, installCabalExecTo, noProfilingLibrary, noDocumentationLibrary,
utilsPackageName, extraDevDeps, installData, installCabalExec, file, apacheSite, installDir, buildDir,
dataDir, intermediateFiles)
import Debian.Debianize.ControlFile as Debian (SourceDebDescription(..), BinaryDebDescription(..), PackageRelations(..),
newBinaryDebDescription, modifyBinaryDeb,
PackageType(Exec, Development, Profiling, Documentation, Utilities))
import Debian.Debianize.Dependencies (debianName, binaryPackageDeps, binaryPackageConflicts, binaryPackageProvides, binaryPackageReplaces, putBuildDeps)
import Debian.Debianize.Goodies (describe, siteAtoms, serverAtoms, backupAtoms, execAtoms)
import Debian.Debianize.Types (InstallFile(..))
import Debian.Policy (PackageArchitectures(Any, All), Section(..))
import Debian.Relation (Relation(Rel), BinPkgName(BinPkgName))
import Distribution.Package (PackageName(PackageName), PackageIdentifier(..))
import qualified Distribution.PackageDescription as Cabal
import Prelude hiding (init, unlines, writeFile, map, log)
import System.FilePath ((</>), (<.>), makeRelative, splitFileName, takeDirectory, takeFileName)
import Text.PrettyPrint.ANSI.Leijen (pretty)
finalizeDebianization :: Atoms -> Atoms
finalizeDebianization atoms0 =
g $ finalizeAtoms $ makeUtilsPackage $ librarySpecs $ putBuildDeps $ f $ finalizeAtoms $ atoms0
where
f :: Atoms -> Atoms
f atoms = (\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL website atoms)) .
(\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL serverInfo atoms)) .
(\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> modL binaryArchitectures (Map.insertWith (flip const) b Any) . cabalExecBinaryPackage b $ atoms'') atoms' (getL backups atoms)) .
(\ atoms' -> Map.foldWithKey (\ b _ atoms'' -> cabalExecBinaryPackage b atoms'') atoms' (getL executable atoms)) $ atoms
g :: Atoms -> Atoms
g atoms = (\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {priority = Just x}) atoms') (getL sourcePriority atoms)) .
(\ atoms' -> maybe atoms' (\ x -> modL control (\ y -> y {section = Just x}) atoms') (getL sourceSection atoms)) .
(\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {architecture = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryArchitectures atoms)) .
(\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binaryPriority = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binaryPriorities atoms)) .
(\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {binarySection = Just x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL binarySections atoms)) .
(\ atoms' -> Map.foldWithKey (\ b x atoms'' -> modL control (\ y -> modifyBinaryDeb b ((\ bin -> bin {Debian.description = x}) . fromMaybe (newBinaryDebDescription b Any)) y) atoms'') atoms' (getL Atoms.description atoms)) $ atoms
cabalExecBinaryPackage :: BinPkgName -> Atoms -> Atoms
cabalExecBinaryPackage b deb =
modL control (\ y -> y {binaryPackages = bin : binaryPackages y}) deb
where
bin = BinaryDebDescription
{ Debian.package = b
, architecture = Any
, binarySection = Just (MainSection "misc")
, binaryPriority = Nothing
, essential = False
, Debian.description = describe deb Exec (Cabal.package pkgDesc)
, relations = binaryPackageRelations b Exec deb
}
pkgDesc = fromMaybe (error "cabalExecBinaryPackage: no PackageDescription") $ getL packageDescription deb
binaryPackageRelations :: BinPkgName -> PackageType -> Atoms -> PackageRelations
binaryPackageRelations b typ deb =
PackageRelations
{ Debian.depends = [anyrel "${shlibs:Depends}", anyrel "${haskell:Depends}", anyrel "${misc:Depends}"] ++
(if typ == Development then List.map (: []) (toList (getL extraDevDeps deb)) else []) ++
binaryPackageDeps b deb
, recommends = [anyrel "${haskell:Recommends}"]
, suggests = [anyrel "${haskell:Suggests}"]
, preDepends = []
, breaks = []
, conflicts = [anyrel "${haskell:Conflicts}"] ++ binaryPackageConflicts b deb
, provides_ = [anyrel "${haskell:Provides}"] ++ binaryPackageProvides b deb
, replaces_ = [anyrel "${haskell:Replaces}"] ++ binaryPackageReplaces b deb
, builtUsing = []
}
librarySpecs :: Atoms -> Atoms
librarySpecs deb | isNothing (getL packageDescription deb) = deb
librarySpecs deb =
(if doc
then modL link (Map.insertWith Set.union debName (singleton ("/usr/share/doc" </> show (pretty debName) </> "html" </> cabal <.> "txt", "/usr/lib/ghc-doc/hoogle" </> hoogle <.> "txt")))
else id) $
modL control
(\ y -> y { binaryPackages =
(if dev then [librarySpec deb Any Development (Cabal.package pkgDesc)] else []) ++
(if prof then [librarySpec deb Any Profiling (Cabal.package pkgDesc)] else []) ++
(if doc then [docSpecsParagraph deb (Cabal.package pkgDesc)] else []) ++
(binaryPackages y) })
deb
where
doc = dev && not (getL noDocumentationLibrary deb)
prof = dev && not (getL noProfilingLibrary deb)
dev = isJust (Cabal.library pkgDesc)
pkgDesc = fromMaybe (error "librarySpecs: no PackageDescription") $ getL packageDescription deb
PackageName cabal = pkgName (Cabal.package pkgDesc)
debName :: BinPkgName
debName = debianName deb Documentation (Cabal.package pkgDesc)
hoogle = List.map toLower cabal
docSpecsParagraph :: Atoms -> PackageIdentifier -> BinaryDebDescription
docSpecsParagraph atoms pkgId =
BinaryDebDescription
{ Debian.package = debianName atoms Documentation pkgId
, architecture = All
, binarySection = Just (MainSection "doc")
, binaryPriority = Nothing
, essential = False
, Debian.description = describe atoms Documentation pkgId
, relations = binaryPackageRelations (debianName atoms Documentation pkgId) Development atoms
}
librarySpec :: Atoms -> PackageArchitectures -> PackageType -> PackageIdentifier -> BinaryDebDescription
librarySpec atoms arch typ pkgId =
BinaryDebDescription
{ Debian.package = debianName atoms typ pkgId
, architecture = arch
, binarySection = Nothing
, binaryPriority = Nothing
, essential = False
, Debian.description = describe atoms typ pkgId
, relations = binaryPackageRelations (debianName atoms typ pkgId) Development atoms
}
makeUtilsPackage :: Atoms -> Atoms
makeUtilsPackage deb | isNothing (getL packageDescription deb) = deb
makeUtilsPackage deb =
case (Set.difference availableData installedData, Set.difference availableExec installedExec) of
(datas, execs) | Set.null datas && Set.null execs -> deb
(datas, execs) ->
let p = fromMaybe (debianName deb Utilities (Cabal.package pkgDesc)) (getL utilsPackageName deb)
deb' = setL packageDescription (Just pkgDesc) . makeUtilsAtoms p datas execs $ deb in
modL control (\ y -> modifyBinaryDeb p (f deb' p (if Set.null execs then All else Any)) y) deb'
where
f _ _ _ (Just bin) = bin
f deb' p arch Nothing =
let bin = newBinaryDebDescription p arch in
bin {binarySection = Just (MainSection "misc"),
relations = binaryPackageRelations p Utilities deb'}
pkgDesc = fromMaybe (error "makeUtilsPackage: no PackageDescription") $ getL packageDescription deb
availableData = Set.fromList (Cabal.dataFiles pkgDesc)
availableExec = Set.map Cabal.exeName (Set.filter (Cabal.buildable . Cabal.buildInfo) (Set.fromList (Cabal.executables pkgDesc)))
installedData :: Set FilePath
installedData = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL install deb) <>
(List.map fst . concat . List.map toList . elems $ getL installTo deb) <>
(List.map fst . concat . List.map toList . elems $ getL installData deb))
installedExec :: Set String
installedExec = Set.fromList ((List.map fst . concat . List.map toList . elems $ getL installCabalExec deb) <>
(List.map fst . concat . List.map toList . elems $ getL installCabalExecTo deb) <>
(List.map ename . elems $ getL executable deb))
where ename i =
case sourceDir i of
(Nothing) -> execName i
(Just s) -> s </> execName i
makeUtilsAtoms :: BinPkgName -> Set FilePath -> Set String -> Atoms -> Atoms
makeUtilsAtoms p datas execs atoms0 =
if Set.null datas && Set.null execs
then atoms0
else modL rulesFragments (Set.insert (pack ("build" </> show (pretty p) ++ ":: build-ghc-stamp\n"))) . g $ atoms0
where
g :: Atoms -> Atoms
g atoms = Set.fold execAtom (Set.fold dataAtom atoms datas) execs
dataAtom path atoms = modL installData (insertWith union p (singleton (path, path))) atoms
execAtom name atoms = modL installCabalExec (insertWith union p (singleton (name, "usr/bin"))) atoms
anyrel :: String -> [Relation]
anyrel x = anyrel' (BinPkgName x)
anyrel' :: BinPkgName -> [Relation]
anyrel' x = [Rel x Nothing Nothing]
finalizeAtoms :: Atoms -> Atoms
finalizeAtoms atoms | atoms == mempty = atoms
finalizeAtoms atoms = atoms <> finalizeAtoms (expandAtoms atoms)
expandAtoms :: Atoms -> Atoms
expandAtoms old =
expandApacheSite .
expandInstallCabalExec .
expandInstallCabalExecTo .
expandInstallData .
expandInstallTo .
expandFile .
expandWebsite .
expandServer .
expandBackups .
expandExecutable $
mempty
where
expandApacheSite :: Atoms -> Atoms
expandApacheSite new =
foldWithKey (\ b (dom, log, text) atoms ->
modL link (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available/" ++ dom, "/etc/apache2/sites-enabled/" ++ dom))) .
modL installDir (Map.insertWith Set.union b (singleton log)) .
modL file (Map.insertWith Set.union b (singleton ("/etc/apache2/sites-available" </> dom, text))) $
atoms)
new
(getL apacheSite old)
expandInstallCabalExec :: Atoms -> Atoms
expandInstallCabalExec new =
foldWithKey (\ b pairs atoms -> Set.fold (\ (name, dst) atoms' -> modL install (Map.insertWith Set.union b (singleton (builddir </> name </> name, dst))) atoms')
atoms
pairs)
new
(getL installCabalExec old)
where
builddir = fromMaybe "dist-ghc/build" (getL buildDir old)
expandInstallCabalExecTo :: Atoms -> Atoms
expandInstallCabalExecTo new =
foldWithKey (\ b pairs atoms ->
Set.fold (\ (n, d) atoms' ->
modL rulesFragments (Set.insert (Text.unlines
[ pack ("binary-fixup" </> show (pretty b)) <> "::"
, "\tinstall -Dps " <> pack (builddir </> n </> n) <> " " <> pack ("debian" </> show (pretty b) </> makeRelative "/" d) ])) atoms')
atoms
pairs)
new
(getL installCabalExecTo old)
where
builddir = fromMaybe "dist-ghc/build" (getL buildDir old)
expandInstallData :: Atoms -> Atoms
expandInstallData new =
foldWithKey (\ b pairs atoms ->
Set.fold (\ (s, d) atoms' ->
if takeFileName s == takeFileName d
then modL install (Map.insertWith Set.union b (singleton (s, datadir </> makeRelative "/" (takeDirectory d)))) atoms'
else modL installTo (Map.insertWith Set.union b (singleton (s, datadir </> makeRelative "/" d))) atoms')
atoms
pairs)
new
(getL installData old)
where
datadir = fromMaybe (error "finalizeAtoms: no dataDir") $ getL dataDir old
expandInstallTo :: Atoms -> Atoms
expandInstallTo new =
foldWithKey (\ p pairs atoms ->
Set.fold (\ (s, d) atoms' ->
modL rulesFragments (Set.insert (Text.unlines
[ pack ("binary-fixup" </> show (pretty p)) <> "::"
, "\tinstall -Dp " <> pack s <> " " <> pack ("debian" </> show (pretty p) </> makeRelative "/" d) ])) atoms') atoms pairs)
new
(getL installTo old)
expandFile :: Atoms -> Atoms
expandFile new =
foldWithKey (\ p pairs atoms ->
Set.fold (\ (path, s) atoms' ->
let (destDir', destName') = splitFileName path
tmpDir = "debian/cabalInstall" </> show (md5 (fromString (unpack s)))
tmpPath = tmpDir </> destName' in
modL intermediateFiles (Set.insert (tmpPath, s)) .
modL install (Map.insertWith Set.union p (singleton (tmpPath, destDir'))) $
atoms')
atoms
pairs)
new
(getL file old)
expandWebsite :: Atoms -> Atoms
expandWebsite new = foldWithKey siteAtoms new (getL website old)
expandServer :: Atoms -> Atoms
expandServer new = foldWithKey (\ b x atoms -> serverAtoms b x False atoms) new (getL serverInfo old)
expandBackups :: Atoms -> Atoms
expandBackups new = foldWithKey backupAtoms new (getL backups old)
expandExecutable :: Atoms -> Atoms
expandExecutable new = foldWithKey execAtoms new (getL executable old)