cb4254fd92f11e42747673719ffa78557d620e07
[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           | BlockAll
70           | Approve HintSpec
71           | Unblock HintSpec
72           | Urgent HintSpec
73           | AgeDays Age [HintSpec]
74   deriving (Show, Eq, Ord)
75
76 readHintFiles :: Config -> IO [Hint]
77 readHintFiles config | Nothing <- hintDir config  = return []
78 readHintFiles config | Just dir <- hintDir config = concat <$> mapM (readHintFile dir) hintFiles
79
80 readHintFile :: FilePath -> (String, [String]) -> IO [Hint]
81 readHintFile dir (file,allowed) =
82     do ex <- doesFileExist (dir </> file)
83        if ex
84          then concatMap (readHintLine allowed) . untilFinished . lines <$> readFile (dir </> file)
85          else return []
86
87 untilFinished :: [String] -> [String]
88 untilFinished = takeWhile (\l -> not ("finished" `isPrefixOf` l))
89
90 readHintLine :: [String] -> String -> [Hint]
91 readHintLine allowed line =
92     case words line of
93         [] -> []
94         cmd:args | cmd `notElem` allowed -> []
95                  | otherwise -> parseHint cmd args
96
97 parseHint "unblock" args = map Unblock $ mapMaybe parseHintSpec args
98 parseHint "block" args = map Block $ mapMaybe parseHintSpec args
99 parseHint "block-udeb" args = map Block $ mapMaybe parseHintSpec args
100 parseHint "remove" args = map Remove $ mapMaybe parseHintSpec args
101 parseHint _       _    = []
102
103 parseHintSpec src = case splitOn "/" src of
104     [src] -> Just $ HintSpec (SourceName (BS.pack src)) Nothing Nothing
105     [src,version] -> Just $ HintSpec (SourceName (BS.pack src)) (Just (DebianVersion (BS.pack version))) Nothing
106     _ -> Nothing
107
108 data HintResults = HintResults {
109     blockedSources :: IxS.Set Source
110     , removedSources :: IxS.Set Source
111     }
112   deriving (Show)
113   
114
115 processHints :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> [Hint] -> HintResults
116 processHints config ai unstable testing general hints = HintResults {..}
117   where blockedSources = IxS.filter isReallyBlockedSource $ sources unstable `IxS.difference` sources testing
118         isReallyBlockedSource srcI = isBlockedSource srcI && not (isUnblockedSource srcI)
119
120         isUnblockedSource srcI = foldl' (isUnblockedBy (ai `lookupSrc` srcI)) False hints
121         isUnblockedBy src True _ = True
122         isUnblockedBy src False (Unblock hintSpec) = hintSpecApplies hintSpec src
123         isUnblockedBy src b _ = b
124
125         isBlockedSource srcI = foldl' (isBlockedBy (ai `lookupSrc` srcI)) False hints
126         isBlockedBy src True _ = True
127         isBlockedBy src False (Block hintSpec) = hintSpecApplies hintSpec src
128         isBlockedBy src b _ = b
129
130         removedSources = IxS.filter isRemovedSource $ sources unstable `IxS.union` sources testing
131         isRemovedSource srcI = foldl' (isRemovedBy (ai `lookupSrc` srcI)) False hints
132         isRemovedBy src True _ = True
133         isRemovedBy src False (Remove hintSpec) = hintSpecApplies hintSpec src
134         isRemovedBy src b _ = b
135
136 -- TODO: binNMU syntax
137 hintSpecApplies (HintSpec sn1 v1 Nothing) (Source name version) = 
138    sn1 == name && maybe True (== version) v1 
139 hintSpecApplies _ _ = False
140
141