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