rpmdepsize.ml

   1 (* rpmdepsize - visualize the size of RPM dependencies
   2  * (C) Copyright 2009 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17  *
  18  * Written by Richard W.M. Jones <rjones@redhat.com>
  19  *)
  20
  21 open Sexplib
  22 TYPE_CONV_PATH "."
  23
  24 open ExtList
  25 open Unix
  26 open Printf
  27
  28 let debug = true
  29
  30 (* This corresponds to the sexpr that we write out from the
  31  * Python code.  OCaml will type-check it.
  32  *)
  33 type root_packages = string * packages
  34 and packages = pkg list
  35 and pkg = {
  36   nevra : string;                       (* name-[epoch:]version-release.arch *)
  37   name : string;
  38   epoch : int;
  39   version : string;
  40   release : string;
  41   arch : string;
  42   size : int64;                         (* installed size, excl. dirs *)
  43   deps : string list;
  44 }
  45  with sexp
  46
  47 (* Full dependency representation.  This is actually a graph because
  48  * it contains dependency loops.  'deps list' is a ref because we
  49  * update it as we are building it.
  50  *)
  51 type deps = Deps of pkg * deps list ref
  52
  53 (* Final tree representation, loops removed, and everything we want to
  54  * display stored in the nodes.
  55  *)
  56 type tree = Tree of pkg * int64 * int64 * GDraw.color * tree list
  57
  58 module StringMap = Map.Make (String)
  59 let (+^) = Int64.add
  60 let sum = List.fold_left (+^) 0L
  61 let spaces n = String.make n ' '
  62
  63 (* Python has privileged access to the yum repodata, so we have to use
  64  * this Python snippet to pull the data that we need out.  This is the
  65  * part of the program that takes ages to run, because Python is as
  66  * slow as a fat snake that's just eaten a huge lunch.  We can't help that.
  67  *)
  68 let repoquery_py = "
  69 import yum
  70 import yum.misc
  71 import sys
  72
  73 yb = yum.YumBase ()
  74
  75 basepkg = yb.pkgSack.returnPackages (patterns=[sys.argv[1]])[0]
  76 deps = dict ({basepkg:False})
  77
  78 # Recursively find all the dependencies.
  79 stable = False
  80 while not stable:
  81     stable = True
  82     for pkg in deps.keys():
  83         if deps[pkg] == False:
  84             deps[pkg] = []
  85             stable = False
  86             for r in pkg.requires:
  87                 ps = yb.whatProvides (r[0], r[1], r[2])
  88                 best = yb._bestPackageFromList (ps.returnPackages ())
  89                 if best.name != pkg.name:
  90                     deps[pkg].append (best)
  91                     if not deps.has_key (best):
  92                         deps[best] = False
  93             deps[pkg] = yum.misc.unique (deps[pkg])
  94
  95 # Get the data out of python as fast as possible so we can
  96 # use a serious language for analysis of the tree.
  97 print \"(%s (\" % basepkg
  98 for pkg in deps.keys():
  99     print \"((nevra %s) (name %s) (epoch %s) (version %s) (release %s) (arch %s) (size %s)\" % (pkg, pkg.name, pkg.epoch, pkg.version, pkg.release, pkg.arch, pkg.installedsize)
 100     print \"(deps (\"
 101     for p in deps[pkg]:
 102         print \"%s \" % p,
 103     print \")))\"
 104 sys.stdout.write (\"))\")  # suppress trailing newline"
 105
 106 let () =
 107   printf "getting repository information (this can take a few seconds ...)\n%!";
 108
 109   (* Run the Python program and read in the generated sexpr. *)
 110   let cmd =
 111     sprintf "python -c %s %s"
 112       (Filename.quote repoquery_py) (Filename.quote Sys.argv.(1)) in
 113   let chan = open_process_in cmd in
 114   ignore (input_line chan); (* drop "Loaded plugins" *)
 115   let root, pkgs =
 116     root_packages_of_sexp (Sexp.of_string (Std.input_all chan)) in
 117   (match close_process_in chan with
 118    | WEXITED 0 -> ()
 119    | WEXITED i -> failwith (sprintf "command exited with status %d" i)
 120    | WSIGNALED i | WSTOPPED i ->
 121        failwith (sprintf "command stopped with signal %d" i)
 122   );
 123
 124   (* Create the dependency graph, probably contains loops so beware. *)
 125   let deps = List.map (fun pkg -> Deps (pkg, ref [])) pkgs in
 126   let depsmap =
 127     List.fold_left (
 128       fun map (Deps (pkg, _) as deps) ->
 129         StringMap.add pkg.nevra deps map
 130     ) StringMap.empty deps in
 131   List.iter (
 132     fun (Deps (pkg, deps)) ->
 133       let deps' = List.map (fun n -> StringMap.find n depsmap) pkg.deps in
 134       deps := List.append !deps deps'
 135   ) deps;
 136
 137   (* For each package, calculate the total installed size of the package,
 138    * which includes all subpackages pulled in.  So it's what would be
 139    * installed if you did 'yum install foo'.
 140    *)
 141   let total pkg =
 142     let seen = ref StringMap.empty in
 143     let rec _total = function
 144       | Deps (pkg, _) when StringMap.mem pkg.nevra !seen -> 0L
 145       | Deps (pkg, { contents = children }) ->
 146           seen := StringMap.add pkg.nevra true !seen;
 147           pkg.size +^ sum (List.map _total children)
 148     in
 149     _total (StringMap.find pkg.nevra depsmap)
 150   in
 151   let totalsmap =
 152     List.fold_left (
 153       fun map pkg -> StringMap.add pkg.nevra (total pkg) map
 154     ) StringMap.empty pkgs in
 155
 156   (* Create the final display tree.  Each node is sorted so that
 157    * children with the largest contribution come first (on the left).
 158    * We remove packages which are already installed by earlier
 159    * (leftward) packages.  At each node we also store total size and
 160    * size of the additional packages.
 161    *)
 162   let tree =
 163     let seen = ref StringMap.empty in
 164     let rec build_tree = function
 165       | Deps (pkg, _) when StringMap.mem pkg.nevra !seen -> None
 166       | Deps (pkg, { contents = children }) ->
 167           (* Sort children by reverse total size. *)
 168           let cmp (Deps (p1, _)) (Deps (p2, _)) =
 169             let t1 = StringMap.find p1.nevra totalsmap in
 170             let t2 = StringMap.find p2.nevra totalsmap in
 171             compare t2 t1
 172           in
 173           let children = List.sort ~cmp children in
 174           seen := StringMap.add pkg.nevra true !seen;
 175           let children = List.filter_map build_tree children in
 176           let total = StringMap.find pkg.nevra totalsmap in
 177           let increm =
 178             let rec sum_child_sizes = function
 179               | Tree (pkg, _, _, _, children) ->
 180                   List.fold_left (
 181                     fun size child -> size +^ sum_child_sizes child
 182                   ) pkg.size children
 183             in
 184             sum_child_sizes (Tree (pkg, 0L, 0L, `WHITE, children)) in
 185           Some (Tree (pkg, total, increm, `WHITE, children))
 186     in
 187     Option.get (build_tree (StringMap.find root depsmap)) in
 188
 189   if debug then (
 190     let rec display ?(indent=0) = function
 191       | Tree (pkg, total, increm, _, children) ->
 192           printf "%s%s %Ld/%Ld/%Ld\n%!"
 193             (spaces indent) pkg.nevra pkg.size increm total;
 194           List.iter (display ~indent:(indent+2)) children
 195     in
 196     display tree
 197   );
 198
 199   (* Max depth of the tree. *)
 200   let depth =
 201     let rec depth = function
 202       | Tree (pkg, _, _, _, children) ->
 203           List.fold_left (fun d c -> max d (1 + depth c)) 1 children
 204     in
 205     depth tree in
 206
 207   (* Allocate a colour to each node in the tree based on its parent.  The
 208    * single top node is always light grey.  The second level nodes are
 209    * primary colours.
 210    *)
 211   let tree =
 212     let Tree (pkg, total, increm, _, level2) = tree in
 213     let level2 =
 214       let pcols = [
 215         `RGB (55000, 0, 0);
 216         `RGB (0, 55000, 0);
 217         `RGB (0, 0, 55000);
 218         `RGB (55000, 55000, 0);
 219         `RGB (0, 55000, 55000);
 220       ] in
 221       let rec colour_level2 cols = function
 222         | [] -> []
 223         | Tree (pkg, total, increm, _, level3) :: level2 ->
 224             let col, cols = match cols with
 225               | [] -> List.hd pcols, List.tl pcols
 226               | col :: cols -> col, cols in
 227             let level3 = colour_level3 col (List.length level3) 0 level3 in
 228             Tree (pkg, total, increm, col, level3)
 229             :: colour_level2 cols level2
 230       and colour_level3 col n i = function
 231         | [] -> []
 232         | Tree (pkg, total, increm, _, leveln) :: level3 ->
 233             let col = scale_colour col n i in
 234             let leveln = colour_level3 col (List.length leveln) 0 leveln in
 235             Tree (pkg, total, increm, col, leveln)
 236             :: colour_level3 col n (i+1) level3
 237       and scale_colour col n i =
 238         let r, g, b = match col with
 239           | `RGB (r, g, b) -> float r, float g, float b
 240           | _ -> assert false in
 241         let i = float i and n = float n in
 242         let scale = 0.8 +. i/.(5.*.n) in
 243         let r = r *. scale in
 244         let g = g *. scale in
 245         let b = b *. scale in
 246         `RGB (int_of_float r, int_of_float g, int_of_float b)
 247       in
 248       colour_level2 pcols level2 in
 249     Tree (pkg, total, increm, `RGB (55000, 55000, 55000), level2) in
 250
 251   (* Open the window. *)
 252   let title = root ^ " - Fedora RPM dependency size viewer" in
 253   let window =
 254     GWindow.window ~width:800 ~height:600 ~title ~allow_shrink:true () in
 255
 256   ignore (window#connect#destroy ~callback:GMain.quit);
 257
 258   let da = GMisc.drawing_area ~packing:window#add () in
 259   da#misc#realize ();
 260   let draw = new GDraw.drawable da#misc#window in
 261
 262   (* Pango contexts used to draw large and small text. *)
 263   let pango_large_context = da#misc#create_pango_context in
 264   pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
 265   let pango_small_context = da#misc#create_pango_context in
 266   pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");
 267
 268   let repaint _ =
 269     (* Get the canvas size and fill the background with white. *)
 270     let width, height = draw#size in
 271     draw#set_background `WHITE;
 272     draw#set_foreground `WHITE;
 273     draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
 274
 275     (* Calculate the scales so we can fit everything into the window. *)
 276     let Tree (_, top_total, top_increm, _, _) = tree in
 277     assert (top_total = top_increm);
 278     let rowheight = float height /. float depth in
 279     let scale = float width /. Int64.to_float top_increm in
 280
 281     (* Now draw the tree. *)
 282     let rec draw_tree y x = function
 283       | Tree (pkg, total, increm, colour, children) ->
 284           (* Draw pkg at (x, y). *)
 285           let width = scale *. Int64.to_float increm in
 286           let pkgsizewidth = scale *. Int64.to_float pkg.size in
 287           draw_pkg x y width pkgsizewidth rowheight colour pkg total increm;
 288
 289           (* Draw the children of pkg at (i, y + rowheight), where
 290            * i starts as x and increments for each child.
 291            *)
 292           let y = y +. rowheight in
 293           let rec loop x = function
 294             | [] -> ()
 295             | child :: children ->
 296                 draw_tree y x child;
 297                 let Tree (_, _, increm, _, _) = child in
 298                 let childwidth = scale *. Int64.to_float increm in
 299                 loop (x +. childwidth) children
 300           in
 301           loop x children
 302
 303     (* Draw a single package. *)
 304     and draw_pkg x y width pkgsizewidth height colour pkg total increm =
 305       let x = int_of_float x in
 306       let y = int_of_float y in
 307       let width = int_of_float width in
 308       let pkgsizewidth = int_of_float pkgsizewidth in
 309       let height = int_of_float height in
 310
 311       if width > 8 then (
 312         draw_pkg_outline x y width pkgsizewidth height colour;
 313         draw_pkg_label x y width height colour pkg total increm
 314       )
 315       else if width >= 4 then
 316         draw_pkg_narrow x y width height colour
 317       (* else nothing *)
 318
 319     and draw_pkg_outline x y width pkgsizewidth height colour =
 320       draw#set_foreground colour;
 321       draw#rectangle ~x:(x+2) ~y:(y+2)
 322         ~width:(width-4) ~height:(height-4)
 323         ~filled:true ();
 324       if pkgsizewidth > 2 then (
 325         draw#set_foreground (darken colour);
 326         draw#rectangle ~x:(x+2) ~y:(y+2)
 327           ~width:(pkgsizewidth-2) ~height:(height-4)
 328           ~filled:true ();
 329         draw#set_foreground (choose_contrasting_colour colour);
 330         draw#set_line_attributes ~style:`ON_OFF_DASH ();
 331         draw#line (x+pkgsizewidth) (y+2) (x+pkgsizewidth) (y+height-2);
 332         draw#set_line_attributes ~style:`SOLID ()
 333       );
 334       draw#set_foreground (`BLACK);
 335       draw#rectangle ~x:(x+2) ~y:(y+2)
 336         ~width:(width-4) ~height:(height-4)
 337         ~filled:false ()
 338
 339     and draw_pkg_label x y width height colour pkg total increm =
 340       (* How to write text in a drawing area, in case it's not
 341        * obvious, which it certainly is not:
 342        * http://www.math.nagoya-u.ac.jp/~garrigue/soft/olabl/lablgtk-list/120.txt
 343        *)
 344       let txt1 = lazy (
 345         let txt = pango_large_context#create_layout in
 346         Pango.Layout.set_text txt (
 347           sprintf "%s
 348 Package: %.1f%% %s (%Ld bytes)
 349 Incremental: %.1f%% %s (%Ld bytes)
 350 Total: %.1f%% %s (%Ld bytes)" pkg.nevra
 351 (display_percent pkg.size) (display_size pkg.size) pkg.size
 352 (display_percent increm) (display_size increm) increm
 353 (display_percent total) (display_size total) total
 354         );
 355         txt
 356       )
 357       and txt2 = lazy (
 358         let txt = pango_small_context#create_layout in
 359         Pango.Layout.set_text txt (
 360           sprintf "%s
 361 Package: %.1f%% %s (%Ld bytes)
 362 Incremental: %.1f%% %s (%Ld bytes)
 363 Total: %.1f%% %s (%Ld bytes)" pkg.nevra
 364 (display_percent pkg.size) (display_size pkg.size) pkg.size
 365 (display_percent increm) (display_size increm) increm
 366 (display_percent total) (display_size total) total
 367         );
 368         txt
 369       )
 370       and txt3 = lazy (
 371         let txt = pango_small_context#create_layout in
 372         Pango.Layout.set_text txt (
 373           sprintf "%s
 374 Pkg: %.1f%% %s (%Ld bytes)
 375 Incr: %.1f%% %s (%Ld bytes)
 376 Tot: %.1f%% %s (%Ld bytes)" pkg.name
 377 (display_percent pkg.size) (display_size pkg.size) pkg.size
 378 (display_percent increm) (display_size increm) increm
 379 (display_percent total) (display_size total) total
 380         );
 381         txt
 382       )
 383       and txt4 = lazy (
 384         let txt = pango_small_context#create_layout in
 385         Pango.Layout.set_text txt (
 386           sprintf "%s
 387 Pkg: %.1f%% %s
 388 Incr: %.1f%% %s
 389 Tot: %.1f%% %s" pkg.name
 390 (display_percent pkg.size) (display_size pkg.size)
 391 (display_percent increm) (display_size increm)
 392 (display_percent total) (display_size total)
 393         );
 394         txt
 395       )
 396       and txt5 = lazy (
 397         let txt = pango_small_context#create_layout in
 398         Pango.Layout.set_text txt (
 399           sprintf "%s\nPkg: %.1f%%\nIncr: %.1f%%\nTot: %.1f%%"
 400             pkg.name
 401             (display_percent pkg.size)
 402             (display_percent increm)
 403             (display_percent total)
 404         );
 405         txt
 406       )
 407       and txt6 = lazy (
 408         let txt = pango_small_context#create_layout in
 409         Pango.Layout.set_text txt (
 410           sprintf "%s Pkg: %.1f%% %s Incr: %.1f%% %s Tot: %.1f%% %s" pkg.name
 411             (display_percent pkg.size) (display_size pkg.size)
 412             (display_percent increm) (display_size increm)
 413             (display_percent total) (display_size total)
 414         );
 415         txt
 416       )
 417       and txt7 = lazy (
 418         let txt = pango_small_context#create_layout in
 419         Pango.Layout.set_text txt (
 420           sprintf "%s %.1f%% %.1f%% %.1f%%" pkg.name
 421             (display_percent pkg.size)
 422             (display_percent increm)
 423             (display_percent total)
 424         );
 425         txt
 426       )
 427       and txt8 = lazy (
 428         let txt = pango_small_context#create_layout in
 429         Pango.Layout.set_text txt (
 430           sprintf "%s" pkg.name
 431         );
 432         txt
 433       ) in
 434       let txts = [ txt1; txt2; txt3; txt4; txt5; txt6; txt7; txt8 ] in
 435
 436       let fore = choose_contrasting_colour colour in
 437
 438       let rec loop = function
 439         | [] -> ()
 440         | txt :: txts ->
 441             let txt = Lazy.force txt in
 442             let { Pango.width = txtwidth;
 443                   Pango.height = txtheight } =
 444               Pango.Layout.get_pixel_extent txt in
 445             (* Now with added fudge-factor. *)
 446             if width >= txtwidth + 8 && height >= txtheight + 8 then
 447               draw#put_layout ~x:(x+4) ~y:(y+4) ~fore txt
 448             else loop txts
 449       in
 450       loop txts
 451
 452     and draw_pkg_narrow x y width height colour =
 453       draw#set_foreground colour;
 454       draw#rectangle ~x:(x+2) ~y:(y+2)
 455         ~width:(width-4) ~height:(height-4) ~filled:true ()
 456
 457     and choose_contrasting_colour = function
 458       | `RGB (r, g, b) ->
 459           if r + g + b > 98304 then `BLACK else `WHITE
 460       | _ -> `WHITE
 461
 462     and darken = function
 463       | `RGB (r, g, b) ->
 464           `RGB (r * 9 / 10, g * 9 / 10, b * 9 / 10)
 465       | _ -> `WHITE
 466
 467     and display_percent bytes =
 468       100. *. Int64.to_float bytes /. Int64.to_float top_total
 469
 470     and display_size bytes =
 471       if bytes > 104_857L then
 472         sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.)
 473       else if bytes > 102L then
 474         sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.)
 475       else
 476         sprintf "%Ld" bytes
 477     in
 478     draw_tree 0. 0. tree;
 479
 480     (* Return false because this is a Gtk event handler. *)
 481     false
 482   in
 483   ignore (da#event#connect#expose ~callback:repaint);
 484
 485   window#show ();
 486   GMain.main ()