2e5c77ff618ea0c856bd68b6639a3916f1f0d680
[sat-britney.git] / TransRules.hs
1 {-# LANGUAGE RecordWildCards, Rank2Types, ImpredicativeTypes, TupleSections #-}
2 -- |
3 -- Module: TransRules
4 -- Copyright: (c) 2011 Joachim Breitner
5 -- License: GPL-2
6 --
7 module TransRules where
8
9 import Data.List
10 import Data.Maybe
11 import qualified Data.ByteString.Char8 as BS
12 import qualified Data.Strict as ST
13 import qualified Data.Map as M
14 import Data.Functor
15 import Data.Function
16 import Control.Arrow ((&&&), first)
17 import Control.Monad.State
18 import Debug.Trace
19 import Safe
20 import GHC.Exts (build)
21
22 import ParseHints
23 import Indices
24 import Types
25 import AtomIndex
26 import LitSat
27 import PrettyPrint
28 import qualified Data.Set as S
29 import qualified IndexSet as IxS
30 import qualified IndexMap as IxM
31
32
33 -- Sources and binaries that will not be in testing, in any case. Can be used
34 -- to skip certain things, most notable generating the dependency information.
35 findNonCandidates :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> BuiltBy -> HintResults
36     -> Producer (SrcI, String)
37 findNonCandidates config ai unstable testing general builtBy hr f x =
38     (toProducer $ outdated ++ missingArch ++ obsolete ++ tooyoung ++ blocked ++ removed ++ isMoreBuggy) f x
39   where tooyoung = 
40             -- packages need to be old enough
41             [ (src, "it is " ++ show age ++ " days old, needs " ++ show minAge) |
42                 src <- IxS.toList sourcesOnlyUnstable,
43                 Just age <- [src `M.lookup` ages general],
44                 let minAge | src `IxS.member` sourcesNew 
45                            = defaultMinAge config
46                            | otherwise
47                            = fromMaybe (defaultMinAge config) $
48                              urgencies general `combine` minAges config $ src,
49                 age <= minAge
50             ] 
51         outdated = 
52             -- release architectures ought not to be out of date
53             [ (newer, "is out of date: " ++ show (ai `lookupBin` binI) ++ " exists in unstable") |
54                 binI <- IxS.toList (binaries unstable),
55                 let srcI = builtBy IxM.! binI,
56                 -- TODO: only release architecture here
57                 newer <- newerSources unstable IxM.! srcI,
58                 newer `IxS.notMember` sources testing
59             ]
60         missingArch = 
61             -- release architectures ought not be missing in unstable
62             [ (srcIu, "is out of date: " ++ show a ++ " not built in unstable") |
63                 (srcIt, archSt) <- IxM.toList (buildsArches testing),
64                 let (Source pkg vt) = ai `lookupSrc` srcIt,
65                 srcIu <- fromMaybe [] $ M.lookup pkg (sourceNames unstable),
66                 srcIu `IxS.notMember` sources testing,
67                 let archSu = fromMaybe S.empty $ IxM.lookup srcIu (buildsArches unstable),
68                 a <- S.toList $ archSt S.\\ archSu
69             ]
70         obsolete = 
71             -- never add a source package to testing that is already superceded
72             [ (src, "it is already superceded by " ++ show (ai `lookupSrc` s)) |
73                 src <- IxS.toList sourcesOnlyUnstable,
74                 (s:_) <- [newerSources unstable IxM.! src]
75             ]
76         blocked = 
77             [ (src, "is blocked by the release team") |
78                 src <- IxS.toList (blockedSources hr)
79             ]
80         removed = 
81             [ (src, "is removed by the release team") |
82                 src <- IxS.toList (removedSources hr),
83                 src `IxS.notMember` sources testing
84             ]
85         isMoreBuggy = 
86             [ (srcI, "has new bug " ++ show (ai `lookupBug` bugI)) |
87                 (aI,bugIs) <- IxM.toList $ bugs unstable,
88                 BinAtom (Binary pkg _ arch) <- return $ ai `lookupAtom` aI,
89                 let inTesting = [ bugI' |
90                         Just (binI's) <- return $ M.lookup (pkg, ST.fromMaybe (archForAll config) arch) $ binaryNames testing,
91                         binI' <- binI's,
92                         bugI'st <- return $ fromMaybe [] $ IxM.lookup (genIndex binI') $ bugs testing,
93                         bugI'su <- return $ fromMaybe [] $ IxM.lookup (genIndex binI') $ bugs unstable,
94                         bugI' <- bugI'st ++ bugI'su
95                         ],
96                 bugI <- bugIs,
97                 bugI `notElem` inTesting,
98                 let srcI = builtBy IxM.! aI
99             ]
100             
101
102         sourcesOnlyUnstable = IxS.difference (sources unstable) (sources testing)
103         sourcesNew = IxS.fromList $ concat $ M.elems $ M.difference (sourceNames unstable) (sourceNames testing)
104
105 -- Binaries that are in testing and will stay there.
106 -- TODO: Force removals
107 findUnmodified :: Config -> SuiteInfo -> SuiteInfo -> IxS.Set Source -> IxS.Set Binary
108 findUnmodified config unstable testing nonCandidates =
109     binaries testing `IxS.intersection` binaries unstable
110   where nonCandidateBins = {-# SCC "nonCandidateBins" #-} IxS.fromList $
111             concatMap (builds unstable IxM.!) $
112             IxS.toList nonCandidates
113
114 transitionRules :: Config -> AtomIndex -> SuiteInfo -> SuiteInfo -> GeneralInfo -> BuiltBy -> HintResults -> Producer (SrcI, String)
115      -> Producer (Clause AtomI)
116 transitionRules config ai unstable testing general builtBy hr nc f x = (toProducer $
117     keepSrc ++ keepBin ++ uniqueBin ++ needsSource ++ binNMUsync ++ newSourceSync ++ completeBuild ++ nonCandidates ++ buggy ) f x
118   where keepSrc = 
119             -- A source that exists both in unstable and in testing has to stay
120             -- in testing, unless a remove hint is present
121             [OneOf atoms ("source " ++ show name ++ " was in testing before.") |
122                 (name,pkgs) <- M.toList sourcesBoth,
123                 all (\src -> src `IxS.notMember` removedSources hr) pkgs,
124                 let atoms = map genIndex (nub pkgs)
125             ]
126         keepBin = 
127             -- A binary that exists both in unstable and in testing has to stay
128             -- in testing, unless a remove hint is present
129             [OneOf atoms ("binary " ++ show name ++ " on " ++ show arch ++ " was in testing before.") |
130                 ((name,arch),pkgs) <- M.toList binariesBoth,
131                 all (\pkg -> builtBy IxM.! pkg `IxS.notMember` removedSources hr) pkgs,
132                 let atoms = map genIndex (nub pkgs)
133             ] 
134         uniqueBin = 
135             -- At most one binary per name and architecture
136             [AtMostOne (nub pkgs) ("at most version of " ++ show name ++ " ought to be unique on " ++ show arch) |
137                 ((name,arch),pkgs') <- M.toList binariesBoth,
138                 let pkgs = map genIndex (nub pkgs'),
139                 length pkgs > 1
140             ]
141         binNMUsync = 
142             -- For each source, keep all binary packages from unstable on an
143             -- architecture together. Assumes that the one-binary-package
144             -- condition is fulfilled in unstable
145             [AllOrNone binIs ("builds should not be separated") |
146                 (src, bins) <- IxM.toList (builds unstable),
147                 binPerArch <- groupBy ((==) `on` binArch . snd) .
148                               sortBy  (compare `on` binArch . snd) .
149                               map (id &&& (ai `lookupBin`)) $ bins,
150                 length binPerArch > 1,
151                 -- Not for arch all, not required
152                 ST.isJust $ binArch (snd (head binPerArch)),
153                 binGroup   <- groupBy ((==)    `on` binVersion . snd) .
154                               sortBy  (compare `on` binVersion . snd) $ binPerArch,
155                 length binGroup > 1,
156                 let binIs = map (genIndex . fst) binGroup
157             ]
158         completeBuild = 
159             -- For each source and each arch each binary name built by the
160             -- source, depend on all binaries with that name. There is exactly
161             -- one such binary, unless there are binNMUs.
162             [Implies (genIndex src) binIs ("all binaries stay with the source") |
163                 src <- IxS.toList (sources testing),
164                 let bins = IxS.toList $ IxS.fromList $
165                         fromMaybe [] (IxM.lookup src (builds unstable)) ++
166                         fromMaybe [] (IxM.lookup src (builds testing)),
167                 binsPerArchAndName <-
168                     map (map fst) .
169                     groupBy ((==) `on` (binArch &&& binName) . snd) .
170                     sortBy  (compare `on` (binArch &&& binName) . snd) .
171                     map (id &&& (ai `lookupBin`)) $ bins,
172                 -- Do not force this if there is not a binary in testing already.
173                 any (`IxS.member` binaries testing) binsPerArchAndName,
174                 let binIs = map genIndex binsPerArchAndName
175             ]
176         newSourceSync =
177             [Implies (genIndex src) binIs ("all binaries stay with the source") |
178                 (src, bins) <- IxM.toList (builds unstable),
179                 src `IxS.notMember` sources testing,
180                 -- This might be redundant, as all these sets will be
181                 -- singletons anyways
182                 binsPerArchAndName <-
183                     map (map fst) .
184                     groupBy ((==) `on` (binArch &&& binName) . snd) .
185                     sortBy  (compare `on` (binArch &&& binName) . snd) .
186                     map (id &&& (ai `lookupBin`)) $ bins,
187                 let binIs = map genIndex binsPerArchAndName
188             ]
189         needsSource = 
190             -- a package needs its source
191             [Implies (genIndex bin) [genIndex src] "of the DFSG" |
192                 (bin, src) <- IxM.toList builtBy,
193                 bin `IxS.notMember` smoothBinaries testing 
194             ] ++
195             -- Smooth upgrades need their source, or a newer version thereof
196             [Implies (genIndex bin) (map genIndex srcIs) "of the DFSG (smooth upgrade)" |
197                 (bin, srcI) <- IxM.toList builtBy,
198                 bin `IxS.member` smoothBinaries testing,
199                 let (Source pkg _) = ai `lookupSrc` srcI,
200                 let srcIs = fromMaybe [] $ M.lookup pkg sourcesUnion
201             ]
202         nonCandidates =
203             [ Not (genIndex atom) reason
204             | (atom, reason) <- build nc
205             ]
206         buggy = 
207             -- no new RC bugs
208             [Implies atom [bug] ("it has this bug") |
209                 (atom, bugs) <- IxM.toList bugsUnion,
210                 bug <- genIndex <$> nub bugs
211             ] ++
212             [Not atom ("it was not in testing before") |
213                 
214                 atom <- genIndex <$> IxS.toList forbiddenBugs
215             ]
216
217         sourcesBoth = M.intersectionWith (++) (sourceNames unstable) (sourceNames testing)
218         sourcesUnion = M.unionWith (++) (sourceNames unstable) (sourceNames testing)
219         binariesBoth =  M.intersectionWith (++) (binaryNames unstable) (binaryNames testing)
220         -- We assume that the dependency information is the same, even from different suites
221
222         bugsUnion = {-# SCC "bugsUnion" #-} IxM.unionWith (++) (bugs unstable) (bugs testing)
223
224         -- This does not work, as bugs with tag "sid" would appear as new bugs
225         -- bugsInTesting = IxS.fromList (concat (M.elems (bugs testing)))
226         -- bugsInUnstable = {-# SCC "bugsInUnstable" #-} IxS.fromList (concat (M.elems (bugs unstable)))
227         bugsInTesting = {-# SCC "bugsInTesting" #-} IxS.fromList [ bug |
228             atom <- IxS.toList (atoms testing),
229             bug <- IxM.findWithDefault [] atom bugsUnion ]
230         bugsInUnstable = {-# SCC "bugsInUnstable" #-} IxS.fromList [ bug |
231             atom <- IxS.toList (atoms unstable),
232             bug <- IxM.findWithDefault [] atom bugsUnion ]
233         forbiddenBugs = {-# SCC "forbiddenBugs" #-} bugsInUnstable `IxS.difference` bugsInTesting
234
235 desiredAtoms :: SuiteInfo -> SuiteInfo -> HintResults -> Producer AtomI
236 desiredAtoms unstable testing hr f x = (toProducer $
237     fmap genIndex $ IxS.toList $ binaries unstable `IxS.difference` binaries testing) f x
238
239 unwantedAtoms :: SuiteInfo -> SuiteInfo -> HintResults -> Producer AtomI
240 unwantedAtoms unstable testing hr f x = (toProducer $ 
241     (fmap genIndex $ IxS.toList $ removedSources hr) ++
242     (fmap genIndex $ IxS.toList $ binaries testing `IxS.difference` binaries unstable)
243     ) f x
244
245 combine :: (Ord a, Ord b) => M.Map a b -> M.Map b c -> a -> Maybe c
246 combine m1 m2 x = (x `M.lookup` m1) >>= (`M.lookup` m2)