[pkg-haskell-tools] 03/03: make-all: Clean up arch checking and filename decomposition
Joachim Breitner
nomeata at moszumanska.debian.org
Wed Aug 19 18:56:53 UTC 2015
This is an automated email from the git hooks/post-receive script.
nomeata pushed a commit to branch architectures
in repository pkg-haskell-tools.
commit e486248d899a11ab3bdf98b5dbdb2a3f19b8a7fa
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Aug 19 20:56:21 2015 +0200
make-all: Clean up arch checking and filename decomposition
but untested yet, hence only on the branch, while I take a hacking
break.
---
src/make-all.hs | 39 ++++++++++++++++++++++++---------------
1 file changed, 24 insertions(+), 15 deletions(-)
diff --git a/src/make-all.hs b/src/make-all.hs
index d1d6d92..0f031d0 100644
--- a/src/make-all.hs
+++ b/src/make-all.hs
@@ -151,6 +151,15 @@ versionOfSource s = do
char ')'
return (removeEpoch v)
+-- Splits the filename of a .deb, .changes or .build file into version, source
+-- and architecture
+splitDebName :: String -> (String, String, String)
+splitDebName filename
+ | [pkgname, version, arch] <- splitOn "_" (dropExtension filename)
+ = (pkgname, version, arch)
+ | otherwise
+ = error $ "splitDebName: Unexpected filename " ++ show filename
+
ensureVersion :: String -> String -> Action ()
ensureVersion s v = do
ex <- doesFileExist $ "p" </> s </> "debian" </> "changelog"
@@ -160,6 +169,14 @@ ensureVersion s v = do
when (v /= v') $ do
fail $ "Cannot build " ++ s ++ " version " ++ v ++ ", as we have " ++ v' ++ "."
+ensureArch :: String -> Action ()
+ensureArch a = do
+ a' <- askOracle (GetArch ())
+ case () of
+ () | a == a' -> return ()
+ | a == "all" -> return ()
+ | otherwise -> fail $ "Demanded architecture " ++ a ++ " does not match schroot architecture " ++ a' ++ "."
+
removeEpoch :: String -> String
removeEpoch s | ':' `elem` s = tail $ dropWhile (/= ':') s
| otherwise = s
@@ -244,11 +261,6 @@ newtype GetBinToDeb = GetBinToDeb String deriving (Show,Typeable,Eq,Hashable,Bi
newtype GetArch = GetArch () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-checkArch :: (Monad m) => String -> String -> String -> m ()
-checkArch should is full = unless ( (should `isPrefixOf` is)
- || ("all" `isPrefixOf` is)) $
- fail $ "Can't build this file " ++ full ++ " with schroot with architecture " ++ should
-
manpage :: String
manpage = unlines [ "TODO" ]
@@ -342,7 +354,7 @@ shakeMain conf@(Conf {..}) = do
builtBy <- readFileLines $ targetDir </> "cache/built-by.txt"
return $ M.fromList [ (pkgname, deb)
| [deb,_source] <- words <$> builtBy
- , let [pkgname,_version,_] = splitOn "_" deb
+ , let (pkgname,_,_) = splitDebName deb
]
getBinToDeb <- addOracle $ \(GetBinToDeb bin) -> M.lookup bin <$> binToDebMap ()
@@ -375,9 +387,8 @@ shakeMain conf@(Conf {..}) = do
-- Binary packages depend on the corresponding changes file log
targetDir </> "*.deb" %> \out -> do
let filename = takeFileName out
- let [_pkgname,version,end] = splitOn "_" filename
- arch <- getArch
- checkArch arch end filename
+ let (_pkgname,version,arch) = splitDebName filename
+ ensureArch arch
sourceMB <- debBuiltBy filename
case sourceMB of
Nothing -> fail $ "File " ++ filename ++ " not built by us."
@@ -386,9 +397,8 @@ shakeMain conf@(Conf {..}) = do
-- Changes files depend on the corresponding log file
targetDir </> "*.changes" %> \out -> do
let filename = takeFileName out
- let [source,version,end] = splitOn "_" filename
- arch <- getArch
- checkArch arch end filename
+ let (source,version,arch) = splitDebName filename
+ ensureArch arch
let logfile = targetDir </> logFileName source version arch
need [logfile]
ok <- doesFileExist out
@@ -400,9 +410,8 @@ shakeMain conf@(Conf {..}) = do
-- Build log depends on the corresponding source, and the dependencies
targetDir </> "*.build" %> \out -> do
let filename = takeFileName out
- let [source,version,end] = splitOn "_" filename
- arch <- getArch
- checkArch arch end filename
+ let (source,version,arch) = splitDebName filename
+ ensureArch arch
let changes = changesFileName source version arch
ensureVersion source version
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/pkg-haskell-tools.git
More information about the Pkg-haskell-commits
mailing list