module Debian.Package.Build.Command
( chdir, pwd
, createDirectoryIfMissing, renameDirectory, renameFile
, confirmPath
, unpackInDir, unpack, packInDir', packInDir
, cabalDebian', cabalDebian, packageVersion
, dpkgParseChangeLog, dpkgParseControl
, debuild, debi', debi, aptGetBuildDepends
, BuildMode (..)
, modeListFromControl, buildPackage, build, rebuild
, removeGhcLibrary
, withCurrentDir'
, readProcess', rawSystem', system'
) where
import Data.Maybe (fromMaybe)
import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
import Control.Monad (when, unless)
import Control.Monad.Trans.Class (lift)
import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.Directory as D
import qualified System.Process as Process
import System.Exit (ExitCode (..))
import Data.Version (Version, versionBranch, showVersion)
import Debian.Package.Data
(Hackage, ghcLibraryBinPackages, ghcLibraryPackages, ghcLibraryDocPackage,
Source, parseChangeLog, DebianVersion, readDebianVersion, origVersion',
Control (..), parseControl)
import Debian.Package.Build.Monad (Trace, traceCommand, traceOut, putLog, bracketTrace_)
splitCommand :: [a] -> (a, [a])
splitCommand = head &&& tail
handleExit :: String -> ExitCode -> IO ()
handleExit cmd = d where
d (ExitFailure rv) = fail $ unwords ["Failed with", show rv ++ ":", cmd]
d ExitSuccess = return ()
readProcess' :: [String] -> Trace String
readProcess' cmd0 = do
traceCommand $ unwords cmd0
lift $ do
let (cmd, args) = splitCommand cmd0
Process.readProcess cmd args ""
rawSystem' :: [String] -> Trace ()
rawSystem' cmd0 = do
traceCommand $ unwords cmd0
lift $ do
let (cmd, args) = splitCommand cmd0
Process.rawSystem cmd args >>= handleExit cmd
system' :: String -> Trace ()
system' cmd = do
traceCommand cmd
lift $ Process.system cmd >>= handleExit cmd
chdir :: String -> Trace ()
chdir dir = do
traceCommand $ "<setCurrentDirectory> " ++ dir
lift $ D.setCurrentDirectory dir
pwd :: IO String
pwd = D.getCurrentDirectory
createDirectoryIfMissing :: String -> Trace ()
createDirectoryIfMissing dir = do
traceCommand $ "<createDirectoryIfMissing True> " ++ dir
lift $ D.createDirectoryIfMissing True dir
renameMsg :: String -> String -> String -> String
renameMsg tag src dst = unwords ["<" ++ tag ++ "> ", src, "-->", dst]
renameDirectory :: String -> String -> Trace ()
renameDirectory src dst = do
traceCommand $ renameMsg "renameDirectory" src dst
lift $ D.renameDirectory src dst
renameFile :: String -> String -> Trace ()
renameFile src dst = do
traceCommand $ renameMsg "renameFile" src dst
lift $ D.renameFile src dst
confirmPath :: String -> Trace ()
confirmPath path =
readProcess' ["ls", "-ld", path] >>= traceOut
unpackInDir :: FilePath -> FilePath -> Trace ()
apath `unpackInDir` dir = do
putLog $ unwords ["Unpacking", apath, "in", dir, "."]
rawSystem' ["tar", "-C", dir, "-zxf", apath]
unpack :: FilePath -> Trace ()
unpack apath = apath `unpackInDir` takeDirectory apath
packInDir' :: FilePath -> FilePath -> FilePath -> Trace ()
packInDir' pdir apath wdir = do
putLog $ unwords ["Packing", pdir, "in", wdir, "into", apath, "."]
rawSystem' ["tar", "-C", wdir, "-zcf", apath, pdir]
packInDir :: FilePath -> FilePath -> Trace ()
pdir `packInDir` wdir =
packInDir' pdir (pdir <.> "tar" <.> "gz") wdir
withCurrentDir' :: FilePath -> Trace a -> Trace a
withCurrentDir' dir act = do
saveDir <- lift pwd
bracketTrace_
(chdir dir)
(chdir saveDir)
act
cabalDebian' :: Maybe String -> Trace ()
cabalDebian' mayRev = do
ver <- origVersion' <$> packageVersion "cabal-debian"
case versionBranch ver of
(x:_) | x <= 1 -> fail $ "Version of cabal-debian is TOO OLD: " ++ showVersion ver ++
" - Under version 1 generates wrong dependencies."
| otherwise -> return ()
[] -> return ()
rawSystem'
[ "cabal-debian"
, "--quilt"
, "--revision=" ++ fromMaybe "1~autogen1" mayRev
]
cabalDebian :: FilePath -> Maybe String -> Trace ()
cabalDebian dir = withCurrentDir' dir . cabalDebian'
packageVersion :: String -> Trace DebianVersion
packageVersion pkg = do
vstr <- readProcess' ["dpkg-query", "--show", "--showformat=${Version}", pkg]
maybe (fail $ "readDebianVersion: failed: " ++ vstr) return
$ readDebianVersion vstr
dpkgParseChangeLog :: FilePath -> Trace Source
dpkgParseChangeLog cpath = do
str <- readProcess' ["dpkg-parsechangelog", "-l" ++ cpath]
maybe (fail $ "parseChangeLog: failed: " ++ str) return
$ parseChangeLog str
dpkgParseControl :: FilePath -> Trace Control
dpkgParseControl cpath = do
putLog $ unwords ["Reading", cpath, "."]
str <- lift $ readFile cpath
maybe (fail $ "parseControl: failed: " ++ str) return
$ parseControl str
run :: String -> [String] -> Trace ()
run cmd = rawSystem' . (cmd :)
debuild' :: [String] -> Trace ()
debuild' = run "debuild"
debuild :: FilePath -> [String] -> Trace ()
debuild dir = withCurrentDir' dir . debuild'
debi' :: [String] -> Trace ()
debi' = rawSystem' . (["sudo", "debi"] ++)
debi :: FilePath -> [String] -> Trace ()
debi dir = withCurrentDir' dir . debi'
aptGetBuildDepends :: FilePath -> Trace ()
aptGetBuildDepends dir =
withCurrentDir' dir $ rawSystem' ["sudo", "apt-get-build-depends"]
data BuildMode = All | Bin | Src | Dep | Indep
deriving (Eq, Show)
modeListFromControl :: Control -> [BuildMode]
modeListFromControl c =
Src
: [ Dep | not . null $ controlArch c ]
++ [ Indep | not . null $ controlAll c ]
hasBinaryBuildMode :: BuildMode -> Bool
hasBinaryBuildMode = not . (== Src)
buildPackage :: FilePath -> BuildMode -> [String] -> Trace ()
buildPackage dir mode opts = do
let modeOpt All = []
modeOpt Bin = ["-b"]
modeOpt Src = ["-S"]
modeOpt Dep = ["-B"]
modeOpt Indep = ["-A"]
debuild dir $ ["-uc", "-us"] ++ modeOpt mode ++ opts
build :: FilePath -> [BuildMode] -> [String] -> Trace ()
build dir modes' opts = do
modes <-
if null modes'
then modeListFromControl <$> dpkgParseControl (dir </> "debian" </> "control")
else return modes'
when (any hasBinaryBuildMode modes) $ aptGetBuildDepends dir
sequence_ [buildPackage dir m opts | m <- modes]
rebuild :: FilePath -> [BuildMode] -> [String] -> Trace ()
rebuild dir modes opts = do
debuild dir ["clean"]
build dir modes opts
removeGhcLibrary :: BuildMode -> Hackage -> Trace ()
removeGhcLibrary mode hkg = do
let pkgs All = ghcLibraryPackages
pkgs Bin = ghcLibraryPackages
pkgs Src = const []
pkgs Dep = ghcLibraryBinPackages
pkgs Indep = (:[]) . ghcLibraryDocPackage
pkgs' = pkgs mode hkg
unless (null pkgs') . system'
$ unwords ["echo '' |", "sudo apt-get remove", unwords pkgs', "|| true"]