e54a6586aa0782e8e809d852a0939e1a2f8cc988
[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 Data.Map as M
17 import Debug.Trace
18
19 import Types
20 import AtomIndex
21 import Arches
22 import qualified IndexSet as IxS
23
24 findUninstallablePackages :: Config -> AtomIndex -> SuiteInfo -> FilePath -> Arch -> IO (IxS.Set Binary)
25 findUninstallablePackages config ai suite dir arch = do
26     let file = dir </> "Packages_" ++ show arch
27     -- edos-debcheck does not like empty files
28     str <- readFile file
29     if all isSpace str
30     then return IxS.empty
31     else do
32         uninstallable <- collectEdosOutput file
33         return $
34             IxS.fromList $
35             map (\bin -> 
36                 case ai `indexBin` bin of
37                     Just binI -> binI
38                     Nothing -> 
39                         -- Work around http://bugs.debian.org/665248
40                         case M.lookup (binName bin, arch) (binaryNames suite) of
41                             Nothing -> error $ show bin ++ " not found in AtomIndex or suite"
42                             Just (binI':_) ->
43                                 --trace ("edos-debcheck returned " ++ show bin ++ ", using " ++ show (ai `lookupBin` binI')) $
44                                 binI'
45                 ) $
46             map (\(name,arch,version) ->
47                 Binary (BinName (BS.pack name))
48                        (DebianVersion (BS.pack version))
49                        (if arch == "all" then ST.Nothing else ST.Just (read arch))) $
50             uninstallable
51
52 collectEdosOutput :: FilePath -> IO [(String, String, String)]
53 collectEdosOutput file = do
54     pkgFile <- openFile file ReadMode
55     (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-quiet", "-xml","-failures"]) { std_in = UseHandle pkgFile, std_out = CreatePipe }
56     Document _ _ root  _ <- xmlParse "edos output" <$> hGetContents edosOut
57     -- How do you actually use this HaXmL? This can not be the correct way:
58     let filter = concatMap ((attributed "package" `x` attributed "architecture" `x` attributed "version" `x` extracted (concat . mapMaybe fst . textlabelled (txt `o` children)) ) keep) . (elm `o` children)
59     return $ map (\((((p,a),v),_),_) -> (p, a, v)) (filter (CElem root noPos))
60