Improve rule description
[sat-britney.git] / DebCheck.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2
3 module DebCheck where
4
5 import System.Process
6 import Text.XML.HaXml hiding ((!),when)
7 import Text.XML.HaXml.Posn (noPos)
8 import System.FilePath
9 import Control.Monad
10 import Data.Maybe
11 import System.IO
12 import Data.Char
13 import Data.Functor
14 import qualified Data.ByteString.Char8 as BS
15 import qualified Data.Strict as ST
16 import qualified System.IO.Strict as ST
17 import qualified Data.Map as M
18 import Debug.Trace
19
20 import Types
21 import AtomIndex
22 import Arches
23 import qualified IndexSet as IxS
24
25 findUninstallablePackages :: Config -> AtomIndex -> SuiteInfo -> FilePath -> Arch -> IO (IxS.Set Binary)
26 findUninstallablePackages config ai suite dir arch = do
27     let file = dir </> "Packages_" ++ show arch
28     -- edos-debcheck does not like empty files
29     str <- readFile file
30     if all isSpace str
31     then return IxS.empty
32     else do
33         uninstallable <- collectEdosOutput file
34         return $
35             IxS.fromList $
36             map (\bin -> 
37                 case ai `indexBin` bin of
38                     Just binI -> binI
39                     Nothing -> 
40                         -- Work around http://bugs.debian.org/665248
41                         case M.lookup (binName bin, arch) (binaryNames suite) of
42                             Nothing -> error $ show bin ++ " not found in AtomIndex or suite"
43                             Just (binI':_) ->
44                                 --trace ("edos-debcheck returned " ++ show bin ++ ", using " ++ show (ai `lookupBin` binI')) $
45                                 binI'
46                 ) $
47             map (\(name,arch,version) ->
48                 Binary (BinName (BS.pack name))
49                        (DebianVersion (BS.pack version))
50                        (if arch == "all" then ST.Nothing else ST.Just (read arch))) $
51             uninstallable
52
53 collectEdosOutput :: FilePath -> IO [(String, String, String)]
54 collectEdosOutput file = do
55     pkgFile <- openFile file ReadMode
56     (_, Just edosOutH, _, pid) <- createProcess $ (proc "edos-debcheck" ["-quiet", "-xml","-failures"]) { std_in = UseHandle pkgFile, std_out = CreatePipe }
57     edosOut <- ST.hGetContents edosOutH
58     waitForProcess pid
59     let Document _ _ root  _ = xmlParse "edos output" edosOut
60     -- How do you actually use this HaXmL? This can not be the correct way:
61     let filter = concatMap ((attributed "package" `x` attributed "architecture" `x` attributed "version" `x` extracted (concat . mapMaybe fst . textlabelled (txt `o` children)) ) keep) . (elm `o` children)
62     return $ map (\((((p,a),v),_),_) -> (p, a, v)) (filter (CElem root noPos))
63