Support for {un}block-udeb
[sat-britney.git] / ParseHints.hs
1 {-# LANGUAGE RecordWildCards, PatternGuards #-}
2
3 module ParseHints where
4
5 import Types
6 import Arches
7 import AtomIndex
8 import qualified IndexSet as IxS
9
10 import Data.List.Split
11 import System.IO
12 import Data.Functor
13 import System.FilePath
14 import System.Directory
15 import qualified Data.ByteString.Char8 as BS
16 import Data.Maybe
17 import Data.Char
18 import Data.List
19
20 {- The format is
21         # comment
22         hint <pkg1>/<ver1> <pkg2>/<ver2> ...
23         easy <pkg1>/<ver1> <pkg2>/<ver2> ...
24         force-hint <pkg1>/<ver1> <pkg2>/<ver2> ...
25         remove <pkg1>/<ver1> ...
26         force <pkg1>/<ver1> ...
27         block <pkg1> <pkg2> <pkg3> ...
28         block-all source
29         approve <pkg1>/<ver1> <pkg2>/<ver2> ...
30         unblock <pkg1>/<ver1> <pkg2>/<ver2> ...
31         urgent <pkg1>/<ver1> <pkg2>/<ver2> ...
32         age-days <days> <pkg1>/<ver1> <pkg2>/<ver2> ...
33         finished
34 -}
35
36 -- Copied from /srv/release.debian.org/britney/etc/britney2.conf for now
37 hintFiles = [
38     ("vorlon"      , hints_all),
39     ("aba"         , hints_all),
40     ("he"          , hints_all),
41     ("luk"         , hints_all),
42     ("zobel"       , hints_standard ++ ["force"]),
43     ("pkern"       , hints_standard ++ ["force"]),
44     ("adsb"        , hints_standard ++ ["force","force-hint"]),
45     ("neilm"       , hints_standard),
46     ("mehdi"       , hints_standard),
47     ("jcristau"    , hints_standard),
48     ("faw"         , hints_helpers),
49     ("nthykier"    , hints_helpers),
50     ("freeze"      , ["block","block-all","block-udeb"]),
51     ("freeze-exception" , ["unblock","unblock-udeb"]),
52     ("test-hints",   hints_all) -- for the test suite
53     ]
54
55 -- Copied from code/b2/britney.py
56 hints_helpers = ["easy", "hint", "remove", "block", "block-udeb", "unblock", "unblock-udeb", "approve"]
57 hints_standard = ["urgent", "age-days"] ++ hints_helpers
58 hints_all = ["force", "force-hint", "block-all"] ++ hints_standard
59
60 data HintSpec = HintSpec SourceName (Maybe DebianVersion) (Maybe Arch)
61   deriving (Show, Eq, Ord)
62
63 data Hint = Easy [HintSpec]
64           | Hint [HintSpec]
65           | ForceHint [HintSpec]
66           | Remove HintSpec
67           | Force HintSpec
68           | Block HintSpec
69           | BlockUdeb HintSpec
70           | BlockAll
71           | Approve HintSpec
72           | Unblock HintSpec
73           | UnblockUdeb HintSpec
74           | Urgent HintSpec
75           | AgeDays Age [HintSpec]
76   deriving (Show, Eq, Ord)
77
78 readHintFiles :: Config -> IO [Hint]
79 readHintFiles config | Nothing <- hintDir config  = return []
80 readHintFiles config | Just dir <- hintDir config = concat <$> mapM (readHintFile dir) hintFiles
81
82 readHintFile :: FilePath -> (String, [String]) -> IO [Hint]
83 readHintFile dir (file,allowed) =
84     do ex <- doesFileExist (dir </> file)
85        if ex
86          then concatMap (readHintLine allowed) . untilFinished . lines <$> readFile (dir </> file)
87          else return []
88
89 untilFinished :: [String] -> [String]
90 untilFinished = takeWhile (\l -> not ("finished" `isPrefixOf` l))
91
92 readHintLine :: [String] -> String -> [Hint]
93 readHintLine allowed line =
94     case words line of
95         [] -> []
96         cmd:args | cmd `notElem` allowed -> []
97                  | otherwise -> parseHint cmd args
98
99 parseHint "unblock" args = map Unblock $ mapMaybe parseHintSpec args
100 parseHint "unblock-udeb" args = map UnblockUdeb $ mapMaybe parseHintSpec args
101 parseHint "block" args = map Block $ mapMaybe parseHintSpec args
102 parseHint "block-udeb" args = map BlockUdeb $ mapMaybe parseHintSpec args
103 parseHint "remove" args = map Remove $ mapMaybe parseHintSpec args
104 parseHint _       _    = []
105
106 parseHintSpec src = case splitOn "/" src of
107     [src] -> Just $ HintSpec (SourceName (BS.pack src)) Nothing Nothing
108     [src,version] -> Just $ HintSpec (SourceName (BS.pack src)) (Just (DebianVersion (BS.pack version))) Nothing
109     _ -> Nothing
110
111 data HintResults = HintResults {
112     blockedSources :: IxS.Set Source
113     , removedSources :: IxS.Set Source
114     }
115   deriving (Show)
116   
117
118 processHints :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> [Hint] -> HintResults
119 processHints config ai unstable testing general hints = HintResults {..}
120   where blockedSources = IxS.filter isReallyBlockedSource $ sources unstable `IxS.difference` sources testing
121         isReallyBlockedSource srcI = (isBlockedSource srcI && not (isUnblockedSource srcI))
122             || (isBlockedUdebSource srcI && not (isUnblockedUdebSource srcI))
123
124         isUnblockedSource srcI = foldl' (isUnblockedBy (ai `lookupSrc` srcI)) False hints
125         isUnblockedBy src True _ = True
126         isUnblockedBy src False (Unblock hintSpec) = hintSpecApplies hintSpec src
127         isUnblockedBy src b _ = b
128
129         isBlockedSource srcI = foldl' (isBlockedBy (ai `lookupSrc` srcI)) False hints
130         isBlockedBy src True _ = True
131         isBlockedBy src False (Block hintSpec) = hintSpecApplies hintSpec src
132         isBlockedBy src b _ = b
133
134         isUnblockedUdebSource srcI = foldl' (isUnblockedUdebBy (ai `lookupSrc` srcI)) False hints
135         isUnblockedUdebBy src True _ = True
136         isUnblockedUdebBy src False (UnblockUdeb hintSpec) = hintSpecApplies hintSpec src
137         isUnblockedUdebBy src b _ = b
138
139         isBlockedUdebSource srcI = foldl' (isBlockedUdebBy (ai `lookupSrc` srcI)) False hints
140         isBlockedUdebBy src True _ = True
141         isBlockedUdebBy src False (BlockUdeb hintSpec) = hintSpecApplies hintSpec src
142         isBlockedUdebBy src b _ = b
143
144         removedSources = IxS.filter isRemovedSource $ sources unstable `IxS.union` sources testing
145         isRemovedSource srcI = foldl' (isRemovedBy (ai `lookupSrc` srcI)) False hints
146         isRemovedBy src True _ = True
147         isRemovedBy src False (Remove hintSpec) = hintSpecApplies hintSpec src
148         isRemovedBy src b _ = b
149
150 -- TODO: binNMU syntax
151 hintSpecApplies (HintSpec sn1 v1 Nothing) (Source name version) = 
152    sn1 == name && maybe True (== version) v1 
153 hintSpecApplies _ _ = False
154
155