b0e12904f77b390991b3539f6b9f6991cbc2470d
[sat-britney.git] / Main.hs
1 {-# LANGUAGE OverloadedStrings, RecordWildCards, ImpredicativeTypes, DoAndIfThenElse #-}
2
3 -- |
4 -- Copyright: (c) 2011 Joachim Breitner
5 -- License: GPL-2
6 --
7
8 import System.Environment
9 import System.FilePath
10 import Text.PrettyPrint
11 import qualified Data.Map as M
12 import qualified Data.Set as S
13 import qualified Data.ByteString.Char8 as BS
14 import qualified Data.ByteString.Lazy.Char8 as L
15 import qualified Data.Strict as ST
16 import qualified Data.Vector as V
17 import Control.Monad
18 import System.IO
19 import System.Console.GetOpt
20 import System.Exit
21 import Data.Functor
22 import Data.Maybe
23 import Data.List
24 import GHC.Exts ( augment, build ) 
25 import Text.Printf
26
27 import qualified IndexSet as IxS
28 import qualified IndexMap as IxM
29 import qualified ArchMap as AM
30
31 import ParseSuite
32 import DebCheck
33 import TransRules
34 import DepRules
35 import Types
36 import Arches
37 import PrettyPrint
38 import ClauseSat
39 import Picosat
40 import LitSat
41 import Hints
42 import Difference
43 import Heidi
44 import ParseHints
45 import Indices
46 import AtomIndex
47 import Stats
48
49 minAgeTable = M.fromList [
50     (Urgency "low", Age 10), 
51     (Urgency "medium", Age 5),
52     (Urgency "high", Age 2),
53     (Urgency "critical", Age 2),
54     (Urgency "emergency", Age 0)
55     ]
56
57 defaultConfig :: Config
58 defaultConfig = Config "." Nothing (V.toList allArches) (V.toList allArches) i386 minAgeTable (Age 10) ["libs","oldlibs"] False 0 AsLargeAsPossible
59                        Nothing False Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
60   where i386 = read "i386"
61
62 openH "-" = return (Just stdout)
63 openH filename = do
64     catch ( do
65             h <- openFile filename WriteMode
66             hSetBuffering h LineBuffering
67             return (Just h)
68         ) $ \e -> do
69         hPutStrLn stderr $ "Error: Couldn't open " ++ filename ++ " for writing:\n" ++ show e
70         exitFailure
71
72 parseAtom :: String -> IO Atom
73 parseAtom s = case BS.split '_' (BS.pack s) of
74     [pkg,version,arch] | arch == "src" ->
75         return $ SrcAtom $ Source (SourceName pkg) (DebianVersion version)
76                        | arch == "all" ->
77         return $ BinAtom $ Binary (BinName pkg) (DebianVersion version) ST.Nothing
78                        | otherwise ->
79         return $ BinAtom $ Binary (BinName pkg) (DebianVersion version) (ST.Just (archFromByteString arch))
80     _ -> do hPutStrLn stderr $ "Error: Could not parse package name \"" ++ s ++ "\", "++
81                                "expecting format name_version_arch, where arch can be src."
82             exitFailure
83
84 toArchList = map archFromByteString . filter (not . BS.null) . BS.splitWith (\c -> c `elem` ", ") . BS.pack
85
86 opts =
87     [ Option "d" ["dir"]
88       (ReqArg (\d config -> return (config { dir = d })) "DIR")
89       "directory containing britney data"
90     , Option "h" ["hints-dir"]
91       (ReqArg (\d config -> return (config { hintDir = Just d })) "DIR")
92       "directory containing britney hints"
93     , Option "a" ["arches"]
94       (ReqArg (\as config -> return (config { arches = toArchList as })) "ARCH,..")
95       "comma-separated list of arches to consider at all.\nDefaults to all"
96     , Option "r" ["release-arches"]
97       (ReqArg (\as config -> return (config { releaseArches = toArchList as })) "ARCH,...")
98       "comma-separated list of arches to consider release critical.\nDefaults to all"
99     , Option "" ["clauses-unrelax"]
100       (ReqArg (\d config -> openH d >>= \h -> return (config { clausesUnrelaxH = h })) "FILE")
101       "print literate clauses before relaxation to this file"
102     , Option "" ["relaxation"]
103       (ReqArg (\d config -> openH d >>= \h -> return (config { relaxationH = h })) "FILE")
104       "print relaxation clauses to this file"
105 {-    , Option "" ["relaxation"]
106       (NoArg (\config -> return (config { verboseRelaxation = True })))
107       "more verbose relaxation output" -}
108     , Option "" ["clauses"]
109       (ReqArg (\d config -> openH d >>= \h -> return (config { clausesH = h })) "FILE")
110       "print literate clauses to this file"
111     , Option "" ["dimacs"]
112       (ReqArg (\d config -> openH d >>= \h -> return (config { dimacsH = h })) "FILE")
113       "print SAT solver input in dimacs format to this file"
114     , Option "" ["difference"]
115       (ReqArg (\d config -> openH d >>= \h -> return (config { differenceH = h })) "FILE")
116       "print result overview to this file"
117     , Option "" ["hints"]
118       (ReqArg (\d config -> openH d >>= \h -> return (config { hintsH = h })) "FILE")
119       "print britney2 hints to this file"
120     , Option "" ["heidi"]
121       (ReqArg (\d config -> openH d >>= \h -> return (config { heidiH = h })) "FILE")
122       "print result in heidi format to this file"
123     , Option "" ["non-candidates"]
124       (ReqArg (\d config -> openH d >>= \h -> return (config { nonCandidatesH = h })) "FILE")
125       "print non-candidates with explanation to this file"
126     , Option "" ["stats"]
127       (NoArg (\config -> return (config { showStats = True })))
128       "print stats for various modelings of the problem"
129     , Option "" ["offset"]
130       (ReqArg (\i config -> return (config { offset = read i })) "DAYS")
131       "Assume we are this many days in the future"
132     , Option "" ["migrate"]
133       (ReqArg (\ss config -> parseAtom ss >>= \s -> return (config { migrateThis = Just s })) "PKG")
134       "find a migration containing this package.\nIf it is a source package, it ignores this package's age"
135     , Option "" ["large"]
136       (NoArg (\config -> return (config { transSize = AsLargeAsPossible })))
137       "find a transition as large as possible (default)"
138     , Option "" ["small"]
139       (NoArg (\config -> return (config { transSize = AsSmallAsPossible })))
140       "find a transition as small as possible (useful with --migrate)"
141     , Option "" ["many-small"]
142       (NoArg (\config -> return (config { transSize = ManySmall })))
143       "find a large transition and split it into many small\ntransitions when printing hints"
144     , Option "" ["any-size"]
145       (NoArg (\config -> return (config { transSize = AnySize })))
146       "find any transition (slightly faster)"
147     ] 
148
149 main = do
150     args <- getArgs
151     name <- getProgName
152     let header = "Usage: " ++ name ++ " -d DIR [OPTION...]\n"
153         footer = "\nInstead of FILE, \"-\" can be used to print to the standard output.\n"
154         usage = hPutStr stderr $ usageInfo header opts ++ footer
155     if null args then usage else do
156     case getOpt Permute opts args of
157         (o,[],[] ) -> do
158             config <- foldM (flip id) defaultConfig o
159             if showStats config
160             then printStats config
161             else runBritney config 
162         (_,_,errs) -> do
163             hPutStr stderr $ unlines errs
164             usage 
165
166 runBritney config = do
167     let ai1 = emptyIndex
168     (unstable, unstableRPI, ai2) <- parseSuite config ai1 (dir config </> "unstable")
169     (testing, testingRPI, ai)  <- parseSuite config ai2 (dir config </> "testing")
170     let builtBy = IxM.union (builtByR unstable) (builtByR testing)
171
172     hPutStrLn stderr $ "Figuring out what packages are not installable in testing:"
173     uninstallable <- AM.buildM (arches config) $
174         findUninstallablePackages config ai testing (dir config </> "testing")
175     hPutStrLn stderr $ "Uninstallability counts: " ++ intercalate ", "
176         [ show a ++ ": " ++ show (IxS.size s) | (a,s) <- AM.toList uninstallable]
177
178     hPutStrLn stderr $ "AtomIndex knows about " ++ show (unIndex (maxIndex ai)) ++ " atoms."
179
180     config <- case migrateThis config of
181         Nothing -> return config
182         Just atom -> case ai `indexAtom` atom of 
183             Nothing -> hPutStrLn stderr ("Package " ++ show atom ++ " not known") >> exitFailure
184             Just i -> return $ config { migrateThisI = Just i }
185
186     general <- parseGeneralInfo config ai
187
188     hints <- readHintFiles config
189     hPutStrLn stderr $ "Read " ++ show (length hints) ++ " hints."
190     let hintResults = processHints config ai unstable testing general hints
191
192     let nonCandidates :: Producer (SrcI, String)
193         nonCandidates = findNonCandidates config ai unstable testing general builtBy hintResults
194         nonCandidateSet = IxS.fromList $ map fst $ build nonCandidates
195
196
197     hPutStrLn stderr $ "In unstable are " ++ show (IxS.size (sources unstable `IxS.difference` sources testing)) ++ " new sources, out of which " ++ show (IxS.size nonCandidateSet) ++ " are not candidates."
198
199     mbDo (nonCandidatesH config) $ \h -> do
200         hPutStrLn h $ "The non-candidates are:"
201         forM_ (build nonCandidates) $ \(src, reason) ->
202             hPutStrLn h $ show (pp ai src) ++ " " ++ reason
203
204     let transRules = transitionRules config ai unstable testing general builtBy hintResults nonCandidates
205         desired = desiredAtoms unstable testing hintResults
206         -- In many-small-mode, we do not try to remove packages, as
207         -- that would yield far too many individual removals
208         unwanted | transSize config == ManySmall = toProducer [] 
209                  | otherwise        = unwantedAtoms unstable testing hintResults
210         cnfTrans = {-# SCC "cnfTrans" #-} conjs2SATProb (unIndex $ maxIndex ai) $ clauses2CNF transRules
211
212     hPutStrLn stderr $ "Running transition in happy-no-dependency-world..."
213     result <- runClauseSAT (maxIndex ai) desired unwanted cnfTrans
214     maxTransition <- case result of 
215         Left musCNF -> do
216             hPutStrLn stderr "Not even in happy world, things can migrate:"
217             let mus = cnf2Clauses transRules musCNF 
218             print (nest 4 (vcat (map (pp ai) (build mus))))
219             exitFailure
220         Right (newAtomIs) -> return $ IxS.fromDistinctAscList $ S.toAscList newAtomIs
221
222     hPutStrLn stderr $ "Difference between testing and ideal testing:"
223     differenceStats testing unstable maxTransition
224
225     mbDo (find (`IxS.member` sources testing) (IxS.toList nonCandidateSet)) $ \atom ->
226         hPutStrLn stderr $ "ERROR: " ++ show (pp ai atom) ++ " is a non-candidate in testin!"
227
228     -- From here on, we look at dependencies
229
230     let unmod = IxS.generalize maxTransition `IxS.intersection` binaries testing
231     let piOutM = AM.build (arches config) $ \arch ->
232             resolvePackageInfo config False ai nonCandidateSet unmod arch [testing, unstable] [testingRPI, unstableRPI]
233     let piM = AM.map fst piOutM
234     let ps = mergePackageStats $ map snd (AM.elems piOutM)
235     let aiD = foldr (generateInstallabilityAtoms config) ai (AM.elems piM)
236
237     case ps of
238       (PackageStats {..}) -> do
239         hPrintf stderr "Out of %d binary packages, %d are unmodified, but %d are possibly affected.\n"
240             (IxS.size $ binaries unstable `IxS.union` binaries testing)
241             (IxS.size unmod)
242             (IxS.size $ IxS.unions $ map affected $ AM.elems piM)
243
244         hPutStrLn stderr $ "The conflicts affecting most packages are:"
245         mapM_ (hPutStrLn stderr) 
246             [ "   " ++ show (pp ai c1) ++ " -#- " ++ show (pp ai c2) ++ " (" ++ show i ++ " packages)"
247             | ((c1,c2),i) <- histogramToList 10 conflictHistogram ]
248
249         hPutStrLn stderr $ "The packages appearing in most sets of relevant dependencies are:"
250         mapM_ (hPutStrLn stderr) 
251             [ "   " ++ show (pp ai p) ++ " (" ++ show i ++ " packages)"
252             | (p,i) <- histogramToList 10 relevantDepHistogram ]
253
254         when (showStats config) $ do
255             let binCount = sum $ map (IxS.size . relevantBins) $ AM.elems piM
256                 depCount = sum $ map (sum . map length . IxM.elems .depends) $ AM.elems piM
257
258             {-
259             hPrintf stderr "Non-conflict encoding: %d atoms and %d clauses\n" binCount depCount
260
261             hPrintf stderr "Naive encoding (calculated): %d atoms and %d clauses\n" 
262                 (binCount^2)
263                 (binCount * depCount)
264
265             hPrintf stderr "Encoding considering cones: %d atoms and %d clauses\n" 
266                 (binCount + (sum $ map IxS.size $ IxM.elems $ transitiveHull (dependsRel pi)))
267                 (sum $ map (length . (depends pi IxM.!)) $ concatMap IxS.toList $ IxM.elems $ transitiveHull (dependsRel pi))
268
269             hPrintf stderr "Encoding considering easy packages: %d atoms and %d clauses\n" 
270                 (binCount + (sum $ map IxS.size $ map (IxS.filter (not . (`IxS.member` hasConflictInDeps pi))) $ IxM.elems $ transitiveHull (dependsRel pi)))
271                 (sum $ map (length . (depends pi IxM.!)) $ concatMap IxS.toList $ map (IxS.filter (not . (`IxS.member` hasConflictInDeps pi))) $ IxM.elems $ transitiveHull (dependsRel pi))
272             -}
273
274             hPrintf stderr "Encoding considering only relevant conflicts/dependencies: %d atoms and %d clauses\n" 
275                 (binCount + (sum $ map (sum . map IxS.size . IxM.elems . dependsBadHull) $ AM.elems piM))
276                 (sum $ map (\pi -> sum . map (length . (depends pi IxM.!)) . concatMap IxS.toList . IxM.elems . dependsBadHull $ pi) $ AM.elems piM)
277
278         hPrintf stderr "A total of %d packages take part in %d conflicts, %d have conflicts in dependencies, of which %d have bad conflicts.\n"
279             (IxS.size $ hasConflict)
280             (sum $ map (sum . map (length . concatMap fst) . IxM.elems . conflicts) $ AM.elems piM)
281             (IxS.size $ hasConflictInDeps)
282             (sum $ map (IxM.size . dependsBadHull) $ AM.elems piM)
283
284         hPrintf stderr "Size of the relevant dependency hulls: %d\n"
285             (sum $ map (sum . map IxS.size . IxM.elems . dependsBadHull) $ AM.elems piM)
286
287     hPutStrLn stderr $ "After adding installability atoms, AtomIndex knows about " ++ show (unIndex (maxIndex aiD)) ++ " atoms."
288
289     let depRules = unionMapP
290             (\pi -> dependencyRules config aiD (uninstallable AM.! piArch pi) pi) $
291             AM.elems piM 
292         rulesT = mapP (\i -> Not i "we are investigating testing") desired `concatP`
293                  mapP (\i -> OneOf [i] "we are investigating testing") unwanted `concatP`
294                  depRules
295
296     hPutStrLn stderr $ "Constructed " ++ show (length (build rulesT)) ++ " clauses, with " ++ show (length (build desired)) ++ " desired and " ++ show (length (build unwanted)) ++ " unwanted atoms."
297
298     let extraRules = maybe [] (\si -> [OneOf [si] "it was requested"]) (migrateThisI config)
299         amendedRules = toProducer extraRules `concatP` depRules
300         sp = conjs2SATProb (unIndex $ maxIndex aiD)
301                 (clauses2CNF amendedRules `combineCNF` required cnfTrans)
302
303     mbDo (dimacsH config) $ \h -> do
304         hPutStrLn stderr $ "Writing SAT problem im DIMACS problem"
305         L.hPut h $ formatCNF sp
306         hFlush h
307
308     mbDo (clausesH config) $ \h -> do
309         hPutStrLn stderr $ "Writing SAT problem as literal clauses"
310         mapM_ (hPrint h . nest 4 . pp aiD) (build transRules)
311         mapM_ (hPrint h . nest 4 . pp aiD) (build amendedRules)
312         hFlush h
313
314     {-
315     hPutStrLn stderr $ "Desired packages:"
316     hPrint stderr $ nest 4 (vcat (map (pp aiD) desired))
317     -}
318
319     let (desired', unwanted') = case transSize config of
320             AsLargeAsPossible -> (desired, unwanted)
321             ManySmall         -> (desired, unwanted)
322             AsSmallAsPossible -> (unwanted, desired)
323             AnySize           -> (toProducer [], toProducer [])
324
325     hPutStrLn stderr $ "Running main picosat run"
326     result <- if transSize config == ManySmall
327         then runClauseMINMAXSAT (maxIndex aiD) desired' unwanted' sp
328         else fmap (\res -> (res,error "smallTransitions only exists when transSize == ManySmall")) <$>
329              runClauseSAT (maxIndex aiD) desired' unwanted' sp
330     case result of 
331         Left musCNF -> do
332             hPutStrLn stderr $
333                 "No suitable set of packages could be determined, " ++
334                 "because the following requirements conflict:"
335             let mus = cnf2Clauses (transRules `concatP` amendedRules) musCNF 
336             unless (isJust (migrateThis config)) $ do
337                 hPutStrLn stderr "(This should not happen, as this is detected earlier)"
338             print (nest 4 (vcat (map (pp aiD) (build mus))))
339         Right (newAtomIs,smallTransitions) -> do
340
341             let newAtomIis = IxS.fromDistinctAscList (S.toList newAtomIs)
342             hPutStrLn stderr $ "Difference between testing and new testing:"
343             differenceStats testing unstable newAtomIis
344
345             let unmodMissing = unmod `IxS.difference` IxS.generalize newAtomIis
346             unless (IxS.null unmodMissing) $ do
347                 hPutStrLn stderr $ "Something was wrong with my assumptions, these binaries were expected not to be modified, but are now missing in testing:"
348                 hPutStrLn stderr $ show $ nest 4 $ fsep $ punctuate comma $ map (pp ai) $ IxS.toList unmodMissing
349
350             mbDo (differenceH config) $ \h -> do
351                 L.hPut h $ suiteDifference aiD testing newAtomIs
352                 hFlush h
353
354             mbDo (hintsH config) $ \h -> do
355                 if transSize config == ManySmall
356                 then do
357                     hPutStrLn h $ "# Full hint:"
358                     L.hPut h $ generateHints aiD testing builtBy newAtomIs
359                     hPutStrLn h $ "# Small hints:"
360                     forM_ smallTransitions $ \thisTransitionNewAtomsIs-> 
361                         L.hPut h $ generateHints aiD testing builtBy thisTransitionNewAtomsIs
362                     hFlush h
363                 else do
364                     L.hPut h $ generateHints aiD testing builtBy newAtomIs
365                     hFlush h
366
367             mbDo (heidiH config) $ \h -> do
368                 L.hPut h $ generateHeidi aiD newAtomIs
369
370     hPutStrLn stderr $ "Done"
371     
372 differenceStats :: SuiteInfo -> SuiteInfo -> IxS.Set Atom -> IO ()
373 differenceStats testing unstable newAtoms = do
374     let newAtomsSrc = IxS.generalize newAtoms `IxS.intersection` (sources testing `IxS.union` sources unstable)
375     let newAtomsBin = IxS.generalize newAtoms `IxS.intersection` (binaries testing `IxS.union` binaries unstable)
376
377     hPutStrLn stderr $ "  " ++
378         show (IxS.size (newAtomsSrc `IxS.difference` sources testing)) ++ " sources added, " ++ 
379         show (IxS.size (sources testing `IxS.difference` newAtomsSrc)) ++ " sources removed, " ++
380         show (IxS.size (sources testing `IxS.intersection` newAtomsSrc)) ++ " sources remain."
381
382     hPutStrLn stderr $ "  " ++
383         show (IxS.size (newAtomsBin `IxS.difference` binaries testing)) ++ " binaries added, " ++ 
384         show (IxS.size (binaries testing `IxS.difference` newAtomsBin)) ++ " binaries removed, " ++
385         show (IxS.size (binaries testing `IxS.intersection` newAtomsBin)) ++ " binaries remain."
386
387 removeRelated l1 l2 = filter check l1
388  where  si = S.fromList [ (atom, reason) | Implies atom _ reason <- l2 ]
389         sa = S.fromList [ (a1,a2) | NotBoth a1 a2 _ <- l2 ]
390         check c@(Implies atom _ reason) = (atom, reason) `S.notMember` si
391         check (NotBoth a1 a2 _) = (a1, a2) `S.notMember` sa
392         check _ = True