debian-build (empty) → 0.1.0.0
raw patch · 12 files changed
+1264/−0 lines, 12 filesdep +Cabaldep +basedep +debian-buildsetup-changed
Dependencies added: Cabal, base, debian-build, directory, filepath, process, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- debian-build.cabal +53/−0
- mains/odebuild.hs +62/−0
- src/Debian/Package/Build.hs +21/−0
- src/Debian/Package/Build/Cabal.hs +103/−0
- src/Debian/Package/Build/Command.hs +202/−0
- src/Debian/Package/Build/Monad.hs +168/−0
- src/Debian/Package/Build/Sequence.hs +258/−0
- src/Debian/Package/Data.hs +17/−0
- src/Debian/Package/Data/Hackage.hs +130/−0
- src/Debian/Package/Data/Source.hs +218/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ debian-build.cabal view
@@ -0,0 +1,53 @@+name: debian-build+version: 0.1.0.0+synopsis: Debian package build sequence tools+description: This package provides functions to build+ debian package from source tree.+homepage: http://twitter.com/khibino/+license: BSD3+license-file: LICENSE+author: Kei Hibino+maintainer: ex8k.hibino@gmail.com+-- copyright:+category: Debian+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules:+ Debian.Package.Data.Hackage+ Debian.Package.Data.Source+ Debian.Package.Data+ Debian.Package.Build.Monad+ Debian.Package.Build.Cabal+ Debian.Package.Build.Command+ Debian.Package.Build.Sequence+ Debian.Package.Build++-- other-modules:++ build-depends: base <5+ , filepath+ , process+ , directory+ , transformers+ , Cabal++ hs-source-dirs: src+ ghc-options: -Wall++executable odebuild+ build-depends: base <5+ , debian-build++ main-is: odebuild.hs+ hs-source-dirs: mains+ ghc-options: -Wall++source-repository head+ type: git+ location: https://github.com/khibino/haskell-debian-build++source-repository head+ type: mercurial+ location: https://bitbucket.org/khibino/haskell-debian-build
+ mains/odebuild.hs view
@@ -0,0 +1,62 @@+import System.Environment (getProgName, getArgs)+import Control.Monad (void)++import Debian.Package.Data (Source, Hackage)+import Debian.Package.Build+ (BuildMode (All), buildPackage, debi,+ baseDirCurrent, defaultConfig, Build, runBuild, liftTrace,+ sourceDir, removeBuildDir, genSources, removeGhcLibrary)+++source' :: Build ((FilePath, FilePath), Source, Maybe Hackage)+source' =+ maybe (fail "Illegal state: genSources") return =<< genSources++remove' :: Hackage -> Build ()+remove' = liftTrace . removeGhcLibrary All++install' :: Source -> Build ()+install' src = do+ srcDir <- sourceDir src+ liftTrace $ debi srcDir []+++help :: IO ()+help = do+ prog <- getProgName+ putStr . unlines $ map unwords+ [[prog, "build"],+ [prog, "install"],+ [prog, "reinstall", " -- Remove and install support only for Haskell"] ]++build :: [String] -> Build (Source, Maybe Hackage)+build opts = do+ removeBuildDir+ ((_, dir), src, mayH) <- source'+ liftTrace $ buildPackage dir All opts+ return (src, mayH)++install :: [String] -> Build ()+install args = do+ (src, _mayH) <- build args+ install' src++reinstall :: [String] -> Build ()+reinstall args = do+ (src, mayH) <- build args+ maybe (return ()) remove' mayH+ install' src++run :: Build a -> IO a+run b = uncurry (runBuild b baseDirCurrent) defaultConfig++main :: IO ()+main = do+ as0 <- getArgs+ case as0 of+ "help" : _ -> help+ as1 -> run $ case as1 of+ "build" : args -> void $ build args+ "install" : args -> install args+ "reinstall" : args -> reinstall args+ args -> void $ build args
+ src/Debian/Package/Build.hs view
@@ -0,0 +1,21 @@+-- |+-- Module : Debian.Package.Build+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides build-tool namespace.+module Debian.Package.Build+ ( module Debian.Package.Build.Monad+ , module Debian.Package.Build.Command+ , module Debian.Package.Build.Cabal+ , module Debian.Package.Build.Sequence+ ) where++import Debian.Package.Build.Monad+import Debian.Package.Build.Command+import Debian.Package.Build.Cabal hiding (hackageLongName, hackageName, hackageVersion)+import Debian.Package.Build.Sequence
+ src/Debian/Package/Build/Cabal.hs view
@@ -0,0 +1,103 @@+-- |+-- Module : Debian.Package.Build.Cabal+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module wraps cabal library interfaces to keep sparse dependency to it.+module Debian.Package.Build.Cabal+ ( findDescriptionFile+ , parsePackageDescription+ , hackageLongName, hackageName, hackageVersion++ , setupCmd, clean, sdist+ , configure, build, install, register+ ) where++import Control.Applicative ((<$>))+import Control.Monad (filterM)+import Control.Monad.Trans.Class (lift)+import Data.Maybe (listToMaybe)+import Data.List (isSuffixOf)+import System.FilePath ((</>))+import System.Directory (getDirectoryContents, doesFileExist)+import System.Environment (withArgs)++import Distribution.Text (disp)+import Distribution.Verbosity (silent)+import Distribution.Package (pkgName, pkgVersion)+import Distribution.PackageDescription+ (GenericPackageDescription, packageDescription, PackageDescription, package)+import Distribution.PackageDescription.Parse (readPackageDescription)++import Distribution.Simple (defaultMain)++import Debian.Package.Build.Monad (Trace, traceCommand)+++-- | Find .cabal file+findDescriptionFile :: FilePath -> IO (Maybe FilePath)+findDescriptionFile dir = do+ fs <- getDirectoryContents dir+ let find f+ | length f > length suf &&+ suf `isSuffixOf` f = doesFileExist $ dir </> f+ | otherwise = return False+ where suf = ".cabal"+ fmap (dir </>) . listToMaybe <$> filterM find fs++-- | Parse .cabal file+parsePackageDescription :: FilePath -> IO PackageDescription+parsePackageDescription = (packageDescription `fmap`) . readPackageDescription silent++-- | Hackage name and version string from 'PackageDescription'+hackageLongName :: PackageDescription -> String+hackageLongName = show . disp . package++-- | Hackage name string from 'PackageDescription'+hackageName :: PackageDescription -> String+hackageName = show . disp . pkgName . package++-- | Hackage version string from 'PackageDescription'+hackageVersion :: PackageDescription -> String+hackageVersion = show . disp . pkgVersion . package++_testDotCabal :: IO PackageDescription+_testDotCabal = do Just path <- findDescriptionFile "."+ parsePackageDescription path++setup :: [String] -> Trace ()+setup args = do+ traceCommand (unwords $ "<cabal>" : args)+ lift $ args `withArgs` defaultMain++-- | Call cabal library defaultMain like Setup.hs+setupCmd :: String -> [String] -> Trace ()+setupCmd cmd = setup . (cmd : )++-- | Cabal library defaultMain with sub-command clean+clean :: [String] -> Trace ()+clean = setupCmd "clean"++-- | Cabal library defaultMain with sub-command configure+configure :: [String] -> Trace ()+configure = setupCmd "configure"++-- | Cabal library defaultMain with sub-command sdist+sdist :: [String] -> Trace ()+sdist = setupCmd "sdist"++-- | Cabal library defaultMain with sub-command build+build :: [String] -> Trace ()+build = setupCmd "build"++-- | Cabal library defaultMain with sub-command install+install :: [String] -> Trace ()+install = setupCmd "install"++-- | Cabal library defaultMain with sub-command register+register :: [String] -> Trace ()+register = setupCmd "register"
+ src/Debian/Package/Build/Command.hs view
@@ -0,0 +1,202 @@+-- |+-- Module : Debian.Package.Build.Command+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides trace-able action instances like commands.+module Debian.Package.Build.Command+ ( chdir, pwd++ , createDirectoryIfMissing, renameDirectory, renameFile++ , confirmPath++ , unpackInDir, unpack, packInDir', packInDir++ , cabalDebian', cabalDebian, dpkgParseChangeLog++ , debuild, debi++ , BuildMode (..)++ , buildPackage, rebuild++ , removeGhcLibrary++ , withCurrentDir'++ , readProcess', rawSystem', system'+ ) where++import Data.Maybe (fromMaybe)+import Control.Arrow ((&&&))+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 Debian.Package.Data (Hackage, ghcLibraryBinPackages, ghcLibraryPackages, Source, parseChangeLog)+import Debian.Package.Build.Monad (Trace, traceCommand, traceOut, 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 ()++-- | Run command without shell and get standard output string.+readProcess' :: [String] -> Trace String+readProcess' cmd0 = do+ traceCommand $ unwords cmd0+ lift $ do+ let (cmd, args) = splitCommand cmd0+ Process.readProcess cmd args ""++-- | Run command without shell+rawSystem' :: [String] -> Trace ()+rawSystem' cmd0 = do+ traceCommand $ unwords cmd0+ lift $ do+ let (cmd, args) = splitCommand cmd0+ Process.rawSystem cmd args >>= handleExit cmd++-- | Run command with shell+system' :: String -> Trace ()+system' cmd = do+ traceCommand cmd+ lift $ Process.system cmd >>= handleExit cmd++-- | Change directory action+chdir :: String -> Trace ()+chdir dir = do+ traceCommand $ "<setCurrentDirectory> " ++ dir+ lift $ D.setCurrentDirectory dir++-- | Action to get current working directory+pwd :: IO String+pwd = D.getCurrentDirectory++-- | Create directory if missing+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]++-- | Rename directory action. e.g. /renameDirectory from to/+renameDirectory :: String -> String -> Trace ()+renameDirectory src dst = do+ traceCommand $ renameMsg "renameDirectory" src dst+ lift $ D.renameDirectory src dst++-- | Rename file action. e.g. /renameFile from to/+renameFile :: String -> String -> Trace ()+renameFile src dst = do+ traceCommand $ renameMsg "renameFile" src dst+ lift $ D.renameFile src dst++-- | Confirm filepath using /ls/ command+confirmPath :: String -> Trace ()+confirmPath path =+ readProcess' ["ls", "-ld", path] >>= traceOut+++-- | Unpack .tar.gz under directory.+unpackInDir :: FilePath -> FilePath -> Trace ()+apath `unpackInDir` dir = do+ lift . putStrLn $ unwords ["Unpacking", apath, "in", dir, "."]+ rawSystem' ["tar", "-C", dir, "-zxf", apath]++-- | Unpack .tar.gz under archive place.+unpack :: FilePath -> Trace ()+unpack apath = apath `unpackInDir` takeDirectory apath++-- | Pack directory into .tar.gz under working directory+packInDir' :: FilePath -> FilePath -> FilePath -> Trace ()+packInDir' pdir apath wdir = do+ lift . putStrLn $ unwords ["Packing", pdir, "in", wdir, "into", apath, "."]+ rawSystem' ["tar", "-C", wdir, "-zcf", apath, pdir]++-- | Pack directory into same location .tar.gz under working directory+packInDir :: FilePath -> FilePath -> Trace ()+pdir `packInDir` wdir =+ packInDir' pdir (pdir <.> "tar" <.> "gz") wdir+++-- | Run action under specified directory+withCurrentDir' :: FilePath -> Trace a -> Trace a+withCurrentDir' dir act = do+ saveDir <- lift pwd+ bracketTrace_+ (chdir dir)+ (chdir saveDir)+ act++-- | Just call /cabal-debian/ command+cabalDebian' :: Maybe String -> Trace ()+cabalDebian' mayRev =+ rawSystem'+ [ "cabal-debian"+ , "--debianize" {- for cabal-debian 1.25 -}+ , "--quilt"+ , "--revision=" ++ fromMaybe "1~autogen1" mayRev+ ]++-- | Call /cabal-debian/ command under specified directory+cabalDebian :: FilePath -> Maybe String -> Trace ()+cabalDebian dir = withCurrentDir' dir . cabalDebian'++-- | Read debian changelog file and try to parse into 'Source'+dpkgParseChangeLog :: FilePath -> Trace Source+dpkgParseChangeLog cpath = do+ str <- readProcess' ["dpkg-parsechangelog", "-l" ++ cpath]+ maybe (fail $ "parseChangeLog: failed: " ++ str) return+ $ parseChangeLog str+++run :: String -> [String] -> Trace ()+run cmd = rawSystem' . (cmd :)++debuild' :: [String] -> Trace ()+debuild' = run "debuild"++-- | Call /debuild/ under specified directory, with command line options+debuild :: FilePath -> [String] -> Trace ()+debuild dir = withCurrentDir' dir . debuild'++-- | Install packages under specified source package directory+debi :: FilePath -> [String] -> Trace ()+debi dir = withCurrentDir' dir . rawSystem' . (["sudo", "debi"] ++)++-- | Build mode, all or binary only+data BuildMode = All | Bin++-- | Build package using /debuild/ under specified directory+buildPackage :: FilePath -> BuildMode -> [String] -> Trace ()+buildPackage dir mode opts = do+ let modeOpt All = []+ modeOpt Bin = ["-B"]+ debuild dir $ ["-uc", "-us"] ++ modeOpt mode ++ opts++-- | Clean and build package using /debuild/ under specified directory+rebuild :: FilePath -> BuildMode -> [String] -> Trace ()+rebuild dir mode opts = do+ debuild dir ["clean"]+ buildPackage dir mode opts++-- | Remove ghc library packages under specified source package directory+removeGhcLibrary :: BuildMode -> Hackage -> Trace ()+removeGhcLibrary mode hkg = do+ let pkgs All = ghcLibraryBinPackages+ pkgs Bin = ghcLibraryPackages+ system' $ unwords ["yes '' |", "sudo apt-get remove", unwords $ pkgs mode hkg, "|| true"]
+ src/Debian/Package/Build/Monad.hs view
@@ -0,0 +1,168 @@+-- |+-- Module : Debian.Package.Build.Monad+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides monad types to control build scripts.+module Debian.Package.Build.Monad+ ( Trace, runTrace, traceCommand, traceOut+ , bracketTrace, bracketTrace_++ , BaseDir, baseDirCurrent, baseDirSpecify++ , askBaseDir, askBuildDir++ , BuildDir, buildDirRelative, buildDirAbsolute++ , Config, defaultConfig, buildDir, mayDebianDirName++ , Build, liftTrace, runBuild, askConfig+ , bracketBuild, bracketBuild_+ ) where++import System.FilePath ((</>))+import System.IO (hPutStrLn, hFlush, stderr)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>))+import Control.Monad (when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Exception (bracket)+++readerBracket :: Monad m+ => (m a -> (a -> m b) -> (a -> m c) -> m c)+ -> ReaderT r m a+ -> (a -> ReaderT r m b)+ -> (a -> ReaderT r m c)+ -> ReaderT r m c+readerBracket brkt open close body = do+ r <- ask+ lift $ brkt+ (runReaderT open r)+ (\a -> runReaderT (close a) r)+ (\a -> runReaderT (body a) r)++toBracket_ :: Monad m+ => (m a -> (a -> m b) -> (a -> m c) -> m c)+ -> m a+ -> m b+ -> m c+ -> m c+toBracket_ brkt start end body =+ brkt start (const end) (const body)++-- | Action type with trace flag+type Trace = ReaderT Bool IO++-- | Run 'Trace' monad+runTrace :: Trace a -> Bool -> IO a+runTrace = runReaderT++traceIO :: IO () -> Trace ()+traceIO printIO = do+ t <- ask+ when t $ lift printIO++-- | bracket for 'Trace' monad+bracketTrace :: Trace a -> (a -> Trace b) -> (a -> Trace c) -> Trace c+bracketTrace = readerBracket bracket++-- | bracket_ for 'Trace' monad+bracketTrace_ :: Trace a -> Trace b -> Trace c -> Trace c+bracketTrace_ = toBracket_ bracketTrace++tprint :: Char -> String -> IO ()+tprint pc s = do+ let fh = stderr+ hPutStrLn fh $ pc : " " ++ s+ hFlush fh++-- | Command string trace print along with trace flag+traceCommand :: String -> Trace ()+traceCommand = traceIO . tprint '+'++-- | Output string trace print along with trace flag+traceOut :: String -> Trace ()+traceOut = traceIO . tprint '>'+++-- | Type to specify base directory filepath+newtype BaseDir = BaseDir { unBaseDir :: Maybe FilePath }++-- | Use current directory as base directory+baseDirCurrent :: BaseDir+baseDirCurrent = BaseDir Nothing++-- | Use specified directory as base directory+baseDirSpecify :: FilePath -> BaseDir+baseDirSpecify = BaseDir . Just++-- | Type to specify build working directory+newtype BuildDir = BuildDir (Either FilePath FilePath)++-- | Use relative path from base-dir as build workding directory+buildDirRelative :: FilePath -> BuildDir+buildDirRelative = BuildDir . Left++-- | Use absolute path as build workding directory+buildDirAbsolute :: FilePath -> BuildDir+buildDirAbsolute = BuildDir . Right++-- | Fold build dir+unBuildDir :: FilePath -> BuildDir -> FilePath+unBuildDir base (BuildDir b) = either (base </>) id b++-- | Show 'BuildDir' is relative or absolute+instance Show BuildDir where+ show = d where+ d (BuildDir (Left p)) = "Relative " ++ p+ d (BuildDir (Right p)) = "Absolute " ++ p++-- | Build configuration type+data Config =+ Config+ { buildDir :: BuildDir -- ^ Specify build dir+ , mayDebianDirName :: Maybe FilePath -- ^ Name of debian directory+ } deriving Show++-- | Default configuration+defaultConfig :: (Config, Bool)+defaultConfig = (Config (buildDirRelative ".debian-build") Nothing, True)++-- | Monad type with build base directory and build configuration.+type Build = ReaderT BaseDir (ReaderT Config Trace)++-- | Lift from 'Trace' monad into monad with 'Build' configuration.+liftTrace :: Trace a -> Build a+liftTrace = lift . lift++-- | Run 'Build' configuration monad+runBuild :: Build a -> BaseDir -> Config -> Bool -> IO a+runBuild b bd = runTrace . (runReaderT $ runReaderT b bd)++-- | bracket for 'Build' monad+bracketBuild :: Build a -> (a -> Build b) -> (a -> Build c) -> Build c+bracketBuild = readerBracket $ readerBracket bracketTrace++-- | bracket_ for 'Build' monad+bracketBuild_ :: Build a -> Build b -> Build c -> Build c+bracketBuild_ = toBracket_ bracketBuild++-- | Get base directory in 'Build' monad+askBaseDir :: FilePath -> Build FilePath+askBaseDir cur = fromMaybe cur . unBaseDir <$> ask++-- | Get build configuration in 'Build' monad+askConfig :: Build Config+askConfig = lift ask++-- | Get build working directory in 'Build' monad+askBuildDir :: FilePath -> Build FilePath+askBuildDir cur = do+ bd <- buildDir <$> askConfig+ (`unBuildDir` bd) <$> askBaseDir cur
+ src/Debian/Package/Build/Sequence.hs view
@@ -0,0 +1,258 @@+-- |+-- Module : Debian.Package.Build.Command+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides build-sequence actions.+module Debian.Package.Build.Sequence+ ( origArchive, nativeArchive, sourceDir++ , withCurrentDir, withBaseCurrentDir++ , removeBuildDir++ , copyDebianDir++ , rsyncGenOrigSources, rsyncGenNativeSources, rsyncGenSources++ , cabalGenOrigSources, cabalGenSources, cabalAutogenSources++ , genSources+ ) where++import System.FilePath ((</>), takeFileName, takeDirectory, takeBaseName)+import System.Directory+ (doesDirectoryExist, doesFileExist)+import Control.Applicative (pure, (<$>), (<*>), (<|>))+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)+import Data.Maybe (fromMaybe)+import Data.List (isPrefixOf)++import Debian.Package.Data+ (Hackage, hackageLongName, hackageArchive,+ Source, origArchiveName, nativeArchiveName, sourceDirName, isNative,+ HaskellPackage, hackage, package, haskellPackageFromPackage)+import Debian.Package.Build.Monad+ (Build, liftTrace, bracketBuild_, Config (..), askConfig, askBaseDir, askBuildDir)+import Debian.Package.Build.Command+ (chdir, pwd, createDirectoryIfMissing, confirmPath, renameFile, renameDirectory,+ unpack, packInDir', cabalDebian, dpkgParseChangeLog, rawSystem')+import qualified Debian.Package.Build.Cabal as Cabal+++-- | Run 'Bulid' action under specified directory.+withCurrentDir :: FilePath -> Build a -> Build a+withCurrentDir dir act = do+ saveDir <- liftIO pwd+ bracketBuild_+ (liftTrace $ chdir dir)+ (liftTrace $ chdir saveDir)+ act++-- Take base-directory from 'Build' action context.+getBaseDir :: Build FilePath+getBaseDir = liftIO pwd >>= askBaseDir++-- | Run 'Build' action under base-directory.+withBaseCurrentDir :: Build a -> Build a+withBaseCurrentDir act = do+ baseDir <- getBaseDir+ withCurrentDir baseDir act++-- Take build-directory from 'Build' action context.+getBuildDir :: Build FilePath+getBuildDir = liftIO pwd >>= askBuildDir++-- Pass build-directory to 'Build' action.+withBuildDir :: (FilePath -> Build a) -> Build a+withBuildDir f = getBuildDir >>= f++-- | Remove build-directory.+removeBuildDir :: Build ()+removeBuildDir = do+ bldDir <- getBuildDir+ liftTrace $ do+ found <- liftIO $ doesDirectoryExist bldDir+ when found $ rawSystem' ["rm", "-r", bldDir]++-- | Take debian-directory name from 'Build' action context.+debianDirName :: Build FilePath+debianDirName = do+ mayD <- mayDebianDirName <$> askConfig+ return $ fromMaybe "debian" mayD++-- | Take original source archive name from 'Build' action context.+origArchive :: Source -> Build FilePath+origArchive pkg =+ withBuildDir $ \w -> return $ w </> origArchiveName pkg++-- | Take debian native source archive name from 'Build' action context.+nativeArchive :: Source -> Build FilePath+nativeArchive pkg =+ withBuildDir $ \w -> return $ w </> nativeArchiveName pkg++-- | Take source directory from 'Build' action context.+sourceDir :: Source -> Build FilePath+sourceDir pkg =+ withBuildDir $ \w -> return $ w </> sourceDirName pkg++-- | Action to copy debian directory from base-directory into specified directory.+copyDebianDir :: FilePath -> Build ()+copyDebianDir srcDir = do+ debDN <- debianDirName+ baseDir <- getBaseDir+ liftTrace $ rawSystem' ["cp", "-a", baseDir </> debDN, srcDir </> "."]+++-- Setup source directory under build-directory using rsync.+rsyncGenOrigSourceDir :: Source -> Build FilePath+rsyncGenOrigSourceDir pkg = do+ srcDir <- sourceDir pkg+ debDN <- debianDirName+ baseDir <- getBaseDir+ bldDir <- getBuildDir+ let excludes = [takeFileName d+ | d <- [bldDir]+ , baseDir `isPrefixOf` d ]+ ++ [debDN]+ liftTrace $ do+ createDirectoryIfMissing srcDir+ rawSystem'+ $ ["rsync", "-auv"]+ ++ ["--exclude=" ++ e | e <- excludes]+ ++ [baseDir </> ".", srcDir </> "." ]+ return srcDir++-- | Setup source directory and original source archive under+-- build-directory using rsync.+rsyncGenOrigSources :: Source -> Build (FilePath, FilePath)+rsyncGenOrigSources pkg = do+ srcDir <- rsyncGenOrigSourceDir pkg+ origPath <- origArchive pkg+ withBuildDir $ liftTrace . packInDir' (takeFileName srcDir) origPath+ copyDebianDir srcDir+ liftTrace $ confirmPath srcDir+ return (origPath, srcDir)++-- | Setup native source directory and native source archive under+-- build-directory using rsync.+rsyncGenNativeSources :: Source -> Build (FilePath, FilePath)+rsyncGenNativeSources pkg = do+ srcDir <- rsyncGenOrigSourceDir pkg+ copyDebianDir srcDir+ nativePath <- nativeArchive pkg+ withBuildDir $ liftTrace . packInDir' (takeFileName srcDir) nativePath+ liftTrace $ confirmPath srcDir+ return (nativePath, srcDir)++-- | Setup debian source directory and source archive.+rsyncGenSources :: Source -> Build (FilePath, FilePath)+rsyncGenSources pkg+ | isNative pkg = rsyncGenNativeSources pkg+ | otherwise = rsyncGenOrigSources pkg+++-- Setup source archive using Cabal.+cabalGenArchive :: Hackage -> Build FilePath+cabalGenArchive hkg = do+ withBaseCurrentDir . liftTrace $ Cabal.sdist []+ baseDir <- getBaseDir+ let apath = baseDir </> hackageArchive hkg+ liftTrace $ confirmPath apath+ return apath++-- Setup original source archive using Cabal.+cabalGenOrigArchive :: HaskellPackage -> Build FilePath+cabalGenOrigArchive hpkg = do+ origPath <- origArchive $ package hpkg+ apath <- cabalGenArchive $ hackage hpkg+ liftTrace $ do+ createDirectoryIfMissing $ takeDirectory origPath+ renameFile apath origPath+ return origPath++-- | Setup original source directory and archive using Cabal.+cabalGenOrigSources :: HaskellPackage -> Build (FilePath, FilePath)+cabalGenOrigSources hpkg = do+ origPath <- cabalGenOrigArchive hpkg+ srcDir <- sourceDir $ package hpkg+ liftTrace $ do+ unpack origPath+ renameDirectory+ (takeDirectory origPath </> hackageLongName (hackage hpkg))+ srcDir+ confirmPath srcDir+ return (origPath, srcDir)++-- | Setup source directory and archive using Cabal.+cabalGenSources :: HaskellPackage -> Build (FilePath, FilePath)+cabalGenSources hpkg = do+ pair@(_, srcDir) <- cabalGenOrigSources hpkg+ copyDebianDir srcDir+ return pair++cabalAutogenDebianDir :: Build FilePath+cabalAutogenDebianDir = do+ baseDir <- getBaseDir+ let ddName = "debian"+ tmpDD = baseDir </> ddName+ exist <- liftIO $ doesDirectoryExist tmpDD+ when exist (fail $ "Invalid state: directory already exist: " ++ tmpDD)++ debDir <- (</> ddName) <$> getBuildDir+ liftTrace $ do+ cabalDebian baseDir Nothing+ createDirectoryIfMissing $ takeDirectory debDir+ renameDirectory tmpDD debDir+ return debDir++-- | Setup source directory and archive using Cabal and cabal-debian.+cabalAutogenSources :: String -> Build ((FilePath, FilePath), HaskellPackage)+cabalAutogenSources hname = do+ debDir <- cabalAutogenDebianDir+ pkg <- liftTrace . dpkgParseChangeLog $ debDir </> "changelog"+ hpkg <- either fail return $ haskellPackageFromPackage hname pkg+ pair@(_, srcDir) <- cabalGenOrigSources hpkg+ liftTrace $ renameDirectory debDir (srcDir </> takeFileName debDir)+ return (pair, hpkg)+++findDebianChangeLog :: MaybeT Build FilePath+findDebianChangeLog = MaybeT $ do+ baseDir <- getBaseDir+ debDN <- debianDirName+ let changelog = baseDir </> debDN </> "changelog"+ liftIO $ do+ exist <- doesFileExist changelog+ return $ if exist+ then Just changelog+ else Nothing++findCabalDescription :: MaybeT Build FilePath+findCabalDescription = MaybeT (getBaseDir >>= liftIO . Cabal.findDescriptionFile)++-- | On the fly setup of source directory and archive.+genSources :: Build (Maybe ((FilePath, FilePath), Source, Maybe Hackage))+genSources = runMaybeT $+ do clog <- findDebianChangeLog+ src <- lift . liftTrace $ dpkgParseChangeLog clog+ (do hname <- takeBaseName <$> findCabalDescription+ hpkg <- either fail return $ haskellPackageFromPackage hname src+ p <- lift $ cabalGenSources hpkg+ return (p, src, Just $ hackage hpkg)+ <|>+ do lift $ (,,) <$> rsyncGenSources src <*> pure src <*> pure Nothing)+ <|>+ do hname <- takeBaseName <$> findCabalDescription+ lift $ do+ (p, hpkg) <- cabalAutogenSources hname+ return (p, package hpkg, Just $ hackage hpkg)+ <|>+ do fail "No source generate rule found."
+ src/Debian/Package/Data.hs view
@@ -0,0 +1,17 @@+-- |+-- Module : Debian.Package.Data+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides data-type namespace.+module Debian.Package.Data+ ( module Debian.Package.Data.Hackage+ , module Debian.Package.Data.Source+ ) where++import Debian.Package.Data.Hackage+import Debian.Package.Data.Source
+ src/Debian/Package/Data/Hackage.hs view
@@ -0,0 +1,130 @@+-- |+-- Module : Debian.Package.Data.Hackage+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides data types of hackage meta information.+module Debian.Package.Data.Hackage+ ( HackageVersion, mkHackageVersion, hackageVersionNumbers++ , Hackage, mkHackage, hackageName, hackageVersion+ , debianShortName, mkHackageDefault++ , NameRule (..), debianNamesFromSourceName++ , hackageLongName++ , hackageArchiveName, hackageArchive++ , ghcLibraryBinPackages, ghcLibraryDocPackage, ghcLibraryPackages+ ) where++import Data.List (stripPrefix)+import Data.Char (toLower)+import Data.Version (Version (Version), showVersion, parseVersion)+import Text.ParserCombinators.ReadP (readP_to_S)+import System.FilePath ((</>), (<.>))+++-- | Hackage version type+newtype HackageVersion = HackageVersion (Version)++-- | Make 'HackageVersion'+mkHackageVersion :: Int -> Int -> Int -> Int -> HackageVersion+mkHackageVersion v0 v1 v2 v3 = HackageVersion $ Version [v0, v1, v2, v3] []++-- | Extract hackage version numbers.+hackageVersionNumbers :: HackageVersion -> (Int, Int, Int, Int)+hackageVersionNumbers = d where+ d (HackageVersion (Version [v0, v1, v2, v3] [])) = (v0, v1, v2, v3)+ d hv = error $ "HackageVersion: Invalid structure: " ++ show hv++instance Show HackageVersion where+ show (HackageVersion v) = showVersion v++instance Read HackageVersion where+ readsPrec _ = map toH . filter h . readP_to_S parseVersion where+ h (Version b t, _) = length b == 4 && null t+ toH (v, s) = (HackageVersion v, s)++-- | Hackage name and version type with debian short name. e.g. /src-ext/.+data Hackage = Hackage String HackageVersion String deriving Show++-- | Make 'Hackage'+mkHackage :: String -> HackageVersion -> String -> Hackage+mkHackage = Hackage++-- | Get package name of 'Hackage'+hackageName :: Hackage -> String+hackageName (Hackage n _ _) = n++-- | Get version of 'Hackage'+hackageVersion :: Hackage -> HackageVersion+hackageVersion (Hackage _ v _) = v++-- | Get debian short name of 'Hackage'+debianShortName :: Hackage -> String+debianShortName (Hackage _ _ sn) = sn++-- | Generate 'Hackage' type from package name and version+-- using 'NameRule'+mkHackageDefault :: NameRule -- ^ Rule flag to generate names+ -> String -- ^ Hackage name string+ -> HackageVersion -- ^ Version of hackage+ -> Hackage -- ^ Result hackage meta info+mkHackageDefault rule hname hver = mkHackage hname hver short where+ (_ , short) = debianNamesFromSourceName rule hname++defaultHackageSrcPrefix :: String+defaultHackageSrcPrefix = "haskell-"++-- | Debian short name generate rule+data NameRule = Suggest | Simple deriving (Eq, Show)++-- | Make debian short name from package name using 'NameRule'+debianNamesFromSourceName :: NameRule -- ^ Rule flag to generate name+ -> String -- ^ Debian source name or Hackage name string+ -> (String, String) -- ^ Debian source package name and short name like ("haskell-src-exts", "src-exts")+debianNamesFromSourceName rule hname = d rule where+ lh = map toLower hname+ d Suggest = rec' ["haskell-", "haskell"]+ d Simple = (defaultHackageSrcPrefix ++ lh, lh)+ rec' [] = (defaultHackageSrcPrefix ++ lh, lh)+ rec' (p:ps) = case stripPrefix p lh of+ Just s -> (lh, s)+ Nothing -> rec' ps++-- | Package name string with version+hackageLongName :: Hackage -> String+hackageLongName hkg = hackageName hkg ++ '-' : show (hackageVersion hkg)++-- | Package archive basename+hackageArchiveName :: Hackage -> FilePath+hackageArchiveName hkg = hackageLongName hkg <.> "tar" <.> "gz"++distDir :: String+distDir = "dist"++-- | Package archive pathname+hackageArchive :: Hackage -> FilePath+hackageArchive = (distDir </>) . hackageArchiveName+++-- | Debian library binary package names for GHC+ghcLibraryBinPackages :: Hackage -> [String]+ghcLibraryBinPackages hkg =+ [ concat ["libghc-", debianShortName hkg, '-' : suf]+ | suf <- ["dev", "prof"]+ ]++-- | Debian library document package name for GHC+ghcLibraryDocPackage :: Hackage -> String+ghcLibraryDocPackage hkg = concat ["libghc-", debianShortName hkg, "-doc"]++-- | Debian library package names for GHC+ghcLibraryPackages :: Hackage -> [String]+ghcLibraryPackages hkg = ghcLibraryDocPackage hkg : ghcLibraryBinPackages hkg
+ src/Debian/Package/Data/Source.hs view
@@ -0,0 +1,218 @@+-- |+-- Module : Debian.Package.Data.Source+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides data types of debian source package meta information.+module Debian.Package.Data.Source+ ( DebianVersion, versionFromHackageVersion++ , Source, mkSource, sourceName, version, origVersion, isNative++ , origArchiveName, nativeArchiveName, sourceDirName, deriveHackageVersion++ , parseChangeLog++ , HaskellPackage, hackage, package+ , haskellPackageDefault, haskellPackageFromPackage+ ) where++import Data.Maybe (listToMaybe)+import Control.Arrow (second)+import Control.Monad (ap, MonadPlus, mplus)+import Numeric (readDec)+import Data.Char (isSpace)+import Data.Version (Version (Version, versionBranch), showVersion, parseVersion)+import Text.ParserCombinators.ReadP (ReadP, string, readP_to_S, readS_to_P)+import System.FilePath ((<.>))++import Debian.Package.Data.Hackage+ (HackageVersion, mkHackageVersion, hackageVersionNumbers,+ Hackage, mkHackageDefault, NameRule (Simple), debianNamesFromSourceName)+++-- Combinators like Applicative -- for base-4.5.0.0 - debian wheezy++(<$>) :: Functor m => (a -> b) -> m a -> m b+(<$>) = fmap++pure :: Monad m => a -> m a+pure = return++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap++(*>) :: Monad m => m a -> m b -> m b+(*>) = (>>)++-- (<*) :: (Functor m, Monad m) => m a -> m b -> m a+-- fa <* fb = const <$> fa <*> fb++(<|>) :: MonadPlus m => m a -> m a -> m a+(<|>) = mplus++infixl 3 <|>+infixl 4 <$>, <*>, *>+++-- | Version type for Debian+data DebianVersion+ = DebianNative Version (Maybe Int)+ | DebianNonNative Version String++debianNativeVersion :: [Int] -> Maybe Int -> DebianVersion+debianNativeVersion v = DebianNative (Version v [])++debianNonNativeVersion :: [Int] -> String -> DebianVersion+debianNonNativeVersion v = DebianNonNative (Version v [])++-- | Make deebian version from hackage version+versionFromHackageVersion :: HackageVersion -> Maybe String -> DebianVersion+versionFromHackageVersion hv = d where+ d (Just rev) = debianNonNativeVersion [v0, v1, v2, v3] rev+ d Nothing = debianNativeVersion [v0, v1, v2, v3] Nothing+ (v0, v1, v2, v3) = hackageVersionNumbers hv++origVersion' :: DebianVersion -> Version+origVersion' = d where+ d (DebianNative v _) = v+ d (DebianNonNative v _) = v++isNative' :: DebianVersion -> Bool+isNative' = d where+ d (DebianNative _ _) = True+ d (DebianNonNative _ _) = False++lexWord :: String -> [(String, String)]+lexWord = (:[]) . break isSpace . dropWhile isSpace++returnParsed :: ReadP a -> String -> ReadP a+returnParsed p s = case [ x | (x, "") <- readP_to_S p s ] of+ [x] -> return x+ [] -> fail "ReadP: no parse"+ _ -> fail "ReadP: ambiguous parse"++returnParsedVersion :: String -> ReadP Version+returnParsedVersion = returnParsed parseVersion++returnParsedNMU :: String -> ReadP (Maybe Int)+returnParsedNMU = returnParsed $+ Just <$> (string "+nmu" *> readS_to_P readDec) <|>+ pure Nothing++parseDebianVersion :: ReadP DebianVersion+parseDebianVersion = do+ vs0 <- readS_to_P lexWord+ let (vs1, rtag) = break (== '-') vs0+ (vs2, nmu) = break (== '+') vs1+ if rtag == ""+ then DebianNative <$> returnParsedVersion vs2 <*> returnParsedNMU nmu+ else DebianNonNative <$> returnParsedVersion vs1 <*> return (tail rtag)++instance Show DebianVersion where+ show = d where+ d (DebianNative v nr) = showVersion v ++ maybe "" (("+nmu" ++) . show) nr+ d (DebianNonNative v r) = showVersion v ++ '-': r++instance Read DebianVersion where+ readsPrec _ = readP_to_S parseDebianVersion++readMaybe' :: Read a => String -> Maybe a+readMaybe' = fmap fst . listToMaybe . filter ((== "") . snd) . reads+++-- | Debian source package type, name with version+data Source = Source String DebianVersion deriving Show++-- | Make 'Source'+mkSource :: String -> DebianVersion -> Source+mkSource = Source++-- | Source package name of 'Source'+sourceName :: Source -> String+sourceName (Source n _) = n++-- | Debian version of 'Source'+version :: Source -> DebianVersion+version (Source _ v) = v++-- | Version without debian revision+origVersion :: Source -> Version+origVersion = origVersion' . version++-- | Is debian-native or not+isNative :: Source -> Bool+isNative = isNative' . version++-- | Original source archive basename+origArchiveName :: Source -> FilePath+origArchiveName pkg = sourceName pkg ++ '_' : showVersion (origVersion pkg) <.> "orig" <.> "tar" <.> "gz"++-- | Debian native archive basename+nativeArchiveName :: Source -> String+nativeArchiveName pkg = sourceName pkg ++ '_' : show (version pkg) <.> "tar" <.> "gz"++-- | Source directory basename+sourceDirName :: Source -> FilePath+sourceDirName pkg = sourceName pkg ++ '-' : showVersion (origVersion pkg)++-- | Try to make 'HackageVersion' from 'Source'+deriveHackageVersion :: Source -> Maybe HackageVersion+deriveHackageVersion = d . versionBranch . origVersion where+ d [v0, v1, v2, v3] = Just $ mkHackageVersion v0 v1 v2 v3+ d _ = Nothing++-- | Try to generate 'Source' from debian changelog string+parseChangeLog :: String -- ^ dpkg-parsechangelog result string+ -> Maybe Source -- ^ Source structure+parseChangeLog log' = do+ deb <- mayDebSrc+ dver <- mayDebVer+ return $ mkSource deb dver+ where+ pairs = map (second tail . break (== ' ')) . lines $ log'+ lookup' = (`lookup` pairs)+ mayDebSrc = lookup' "Source:"+ mayDebVer = do+ dverS <- lookup' "Version:"+ readMaybe' dverS+++-- | Debian source package type for Haskell+data HaskellPackage = HaskellPackage Hackage Source deriving Show++-- | 'Hackage' meta-info of 'HaskellPackage'+hackage :: HaskellPackage -> Hackage+hackage (HaskellPackage h _) = h++-- | Debian source package meta-info of 'HaskellPackage'+package :: HaskellPackage -> Source+package (HaskellPackage _ p) = p++-- | Generate 'HaskellPackage' type from debian package name and version+-- using 'NameRule'+haskellPackageDefault :: NameRule+ -> String -- ^ Hackage name string+ -> HackageVersion -- ^ Version of hackage+ -> Maybe String -- ^ Debian revision String+ -> HaskellPackage -- ^ Result structure+haskellPackageDefault rule hname hver mayDevRev =+ HaskellPackage+ (mkHackageDefault rule hname hver)+ (mkSource sn (versionFromHackageVersion hver mayDevRev))+ where+ (sn, _) = debianNamesFromSourceName rule hname++-- | Generate 'HaskellPackage' with hackage name and debian package meta-info+haskellPackageFromPackage :: String -- ^ Hackage name string+ -> Source -- ^ Debian package meta info+ -> Either String HaskellPackage -- ^ Result+haskellPackageFromPackage hname pkg = do+ hv <- maybe (Left "Fail to derive hackage version") Right+ $ deriveHackageVersion pkg+ let hkg = mkHackageDefault Simple hname hv+ return $ HaskellPackage hkg pkg