[pkg-haskell-tools] 03/03: make-all: Clean up arch checking and filename decomposition

[Joachim Breitner]

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