[Pkg-haskell-commits] darcs: tools: Port haskell-pkg-debcheck to dose-debcheck

[Joachim Breitner]

Thu Feb 20 13:01:01 UTC 2014  Joachim Breitner <mail at joachim-breitner.de>
  * Port haskell-pkg-debcheck to dose-debcheck

    M ./haskell-pkg-debcheck.hs -13 +22

Thu Feb 20 13:01:01 UTC 2014  Joachim Breitner <mail at joachim-breitner.de>
  * Port haskell-pkg-debcheck to dose-debcheck
diff -rN -u old-tools/haskell-pkg-debcheck.hs new-tools/haskell-pkg-debcheck.hs
--- old-tools/haskell-pkg-debcheck.hs	2014-02-20 13:01:30.355215941 +0000
+++ new-tools/haskell-pkg-debcheck.hs	2014-02-20 13:01:30.435215917 +0000
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveGeneric, ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards, StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveGeneric, ScopedTypeVariables, OverloadedStrings #-}
 
 import System.Directory
 import System.Process
@@ -10,11 +10,10 @@
 import Data.List.Split
 import Data.Hashable
 import System.IO
-import Text.XML.HaXml hiding ((!),when)
-import Text.XML.HaXml.Posn (noPos)
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy as LB
 --import qualified Codec.Compression.BZip as BZip
+import Data.Yaml
 import qualified Codec.Compression.GZip as GZip
 import Debian.Control
 import Debian.Control.ByteString
@@ -23,22 +22,24 @@
 import Debian.Version
 import Debian.Version.ByteString
 import qualified Debian.Arch
-import qualified Data.HashMap.Lazy as M
+import qualified Data.HashMap.Strict as M
 import Text.PrettyPrint.ANSI.Leijen (pretty)
 -- import Data.Map ((!))
 import qualified Data.HashSet as S
 import Debug.Trace
 import GHC.Generics
 import Text.Printf
+import qualified Data.Vector as V
+import qualified Data.Text as T
 
 m ! k = case M.lookup k m of
-    Just x -> x 
+    Just x -> x
     Nothing -> error $ "Could not find " ++ show k ++ " in map " ++ take 50 (show m) ++ "..."
 
 type Arch = String
 
 
-arches :: [Arch]
+--arches :: [Arch]
 --arches = ["amd64", "i386"]
 arches = words "amd64 armel armhf hurd-i386 i386 mips mipsel powerpc s390x sparc kfreebsd-amd64 kfreebsd-i386"
 
@@ -107,7 +108,7 @@
             LB.readFile (wbDump arch)
     hPutStrLn stderr $ show (M.size wbMap) ++ " source/arch tuples selected."
         
-    hPutStr stderr "# Reading edos-debcheck output..."
+    hPutStr stderr "# Reading dose-debcheck output..."
     problems <- removeArchAll <$> collectEdosOutput (filter isNotIgnored (M.keys bToS))
     hPutStrLn stderr $ show (length problems) ++ " problems detected."
 
@@ -280,12 +281,20 @@
     
 collectEdosOutput :: [BinPkgName] -> IO [(BinPkgName, Arch, DebianVersion, String)]
 collectEdosOutput pkgs = fmap concat $ forM arches $ \arch -> do
-    (_, Just zcatOut, _, _) <- createProcess $ (proc "zcat" [binariesFiles arch]) { std_out = CreatePipe }
-    (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," (map unBinPkgName pkgs)]) { std_in = UseHandle zcatOut, std_out = CreatePipe }
-    Document _ _ root  _ <- xmlParse "edos output" <$> hGetContents edosOut
-    -- How do you actually use this HaXmL? This can not be the correct way:
-    let filter = concatMap ((attributed "package" `x` attributed "architecture" `x` attributed "version" `x` extracted (concat . mapMaybe fst . textlabelled (txt `o` children)) ) keep) . (elm `o` children)
-    return $ map (\((((p,a),v),s),_) -> (BinPkgName p, a, parseDebianVersion v, s)) (filter (CElem root noPos))
+    (_, doseOut, _) <- readProcessWithExitCode "dose-debcheck" ["--failures","--explain","--checkonly", intercalate "," (map unBinPkgName pkgs), binariesFiles arch] ""
+    Object o <- case decodeEither (BS.pack doseOut) of
+        Left e -> fail $ "Failed to parse dose output: " ++ show e
+        Right v -> return v
+    let reports = case M.lookup "report" o of Just (Array v) -> V.toList v
+                                              _              -> []
+    return $ map fromReport reports
+  where
+    fromReport (Object o) = ( BinPkgName $ str "package"
+                   , str "architecture"
+                   , parseDebianVersion $ str "version"
+                   , show (o M.! "reasons")
+                   )
+         where str n = let String s = o M.! n in T.unpack s
 
 removeArchAll :: [(BinPkgName, Arch, DebianVersion, String)] -> [(BinPkgName, Arch, DebianVersion, String)]
 removeArchAll = filter (\(_,a,_,_) -> a /= "all")