virt-df/virt_df.ml

   1 (* 'df' command for virtual domains.
   2    (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19
  20 open Printf
  21 open ExtList
  22 open Unix
  23
  24 open Virt_df_gettext.Gettext
  25
  26 module C = Libvirt.Connect
  27 module D = Libvirt.Domain
  28
  29 (* If set to true, then emit lots of debugging information. *)
  30 let debug = true
  31
  32 (* Int32 infix operators for convenience. *)
  33 let ( +* ) = Int32.add
  34 let ( -* ) = Int32.sub
  35 let ( ** ) = Int32.mul
  36 let ( /* ) = Int32.div
  37
  38 (* Int64 infix operators for convenience. *)
  39 let ( +^ ) = Int64.add
  40 let ( -^ ) = Int64.sub
  41 let ( *^ ) = Int64.mul
  42 let ( /^ ) = Int64.div
  43
  44 (* State of command line arguments. *)
  45 let uri = ref None                      (* Hypervisor/libvirt URI. *)
  46 let inodes = ref false                  (* Display inodes. *)
  47 let human = ref false                   (* Display human-readable. *)
  48 let all = ref false                     (* Show all/active domains. *)
  49 let test_files = ref []                 (* Used for test mode only. *)
  50
  51 (*----------------------------------------------------------------------*)
  52 (* The "domain/device model" that we currently understand looks
  53  * like this:
  54  *
  55  * domains
  56  *   |
  57  *   \--- host partitions / disk image files
  58  *          ||
  59  *        guest block devices
  60  *          |
  61  *          +--> guest partitions (eg. using MBR)
  62  *          |      |
  63  *          \-(1)->+--- filesystems (eg. ext3)
  64  *                 |
  65  *                 \--- PVs for LVM
  66  *                        |||
  67  *                      VGs and LVs
  68  *
  69  * (1) Filesystems and PVs may also appear directly on guest
  70  * block devices.
  71  *
  72  * Partition schemes (eg. MBR) and filesystems register themselves
  73  * with this main module and they are queried first to get an idea
  74  * of the physical devices, partitions and filesystems potentially
  75  * available to the guest.
  76  *
  77  * Volume management schemes (eg. LVM) register themselves here
  78  * and are called later with "spare" physical devices and partitions
  79  * to see if they contain LVM data.  If this results in additional
  80  * logical volumes then these are checked for filesystems.
  81  *
  82  * Swap space is considered to be a dumb filesystem for the purposes
  83  * of this discussion.
  84  *)
  85
  86 (* A virtual (or physical!) device, encapsulating any translation
  87  * that has to be done to access the device.  eg. For partitions
  88  * there is a simple offset, but for LVM you may need complicated
  89  * table lookups.
  90  *
  91  * We keep the underlying file descriptors open for the duration
  92  * of the program.  There aren't likely to be many of them, and
  93  * the program is short-lived, and it's easier than trying to
  94  * track which device is using what fd.  As a result, there is no
  95  * need for any close/deallocation function.
  96  *
  97  * Note the very rare use of OOP in OCaml!
  98  *)
  99 class virtual device =
 100 object (self)
 101   method virtual read : int64 -> int -> string
 102   method virtual size : int64
 103   method virtual name : string
 104
 105   (* Helper method to read a chunk of data into a bitstring. *)
 106   method read_bitstring offset len =
 107     let str = self#read offset len in
 108     (str, 0, len * 8)
 109 end
 110
 111 (* A concrete device which just direct-maps a file or /dev device. *)
 112 class block_device filename =
 113   let fd = openfile filename [ O_RDONLY ] 0 in
 114   let size = (LargeFile.fstat fd).LargeFile.st_size in
 115 object (self)
 116   inherit device
 117   method read offset len =
 118     ignore (LargeFile.lseek fd offset SEEK_SET);
 119     let str = String.make len '\000' in
 120     read fd str 0 len;
 121     str
 122   method size = size
 123   method name = filename
 124 end
 125
 126 (* A null device.  Any attempt to read generates an error. *)
 127 let null_device : device =
 128 object
 129   inherit device
 130   method read _ _ = assert false
 131   method size = 0L
 132   method name = "null"
 133 end
 134
 135 (* Domains and candidate guest block devices. *)
 136
 137 type domain = {
 138   dom_name : string;                    (* Domain name. *)
 139   dom_id : int option;                  (* Domain ID (if running). *)
 140   dom_disks : disk list;                (* Domain disks. *)
 141 }
 142 and disk = {
 143   (* From the XML ... *)
 144   d_type : string option;               (* The <disk type=...> *)
 145   d_device : string;                    (* The <disk device=...> (eg "disk") *)
 146   d_source : string;                    (* The <source file=... or dev> *)
 147   d_target : string;                    (* The <target dev=...> (eg "hda") *)
 148
 149   (* About the device itself. *)
 150   d_dev : device;                       (* Disk device. *)
 151   d_content : disk_content;             (* What's on it. *)
 152 }
 153 and disk_content =
 154   [ `Unknown                            (* Not probed or unknown. *)
 155   | `Partitions of partitions           (* Contains partitions. *)
 156   | `Filesystem of filesystem           (* Contains a filesystem directly. *)
 157   | `PhysicalVolume of unit             (* Contains an LVM PV. *)
 158   ]
 159
 160 (* Partitions. *)
 161
 162 and partitions = {
 163   parts_name : string;                  (* Name of partitioning scheme. *)
 164   parts : partition list                (* Partitions. *)
 165 }
 166 and partition = {
 167   part_status : partition_status;       (* Bootable, etc. *)
 168   part_type : int;                      (* Partition filesystem type. *)
 169   part_dev : device;                    (* Partition device. *)
 170   part_content : partition_content;     (* What's on it. *)
 171 }
 172 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
 173 and partition_content =
 174   [ `Unknown                            (* Not probed or unknown. *)
 175   | `Filesystem of filesystem           (* Filesystem. *)
 176   | `PhysicalVolume of unit             (* Contains an LVM PV. *)
 177   ]
 178
 179 (* Filesystems (also swap devices). *)
 180 and filesystem = {
 181   fs_name : string;                     (* Name of filesystem. *)
 182   fs_block_size : int64;                (* Block size (bytes). *)
 183   fs_blocks_total : int64;              (* Total blocks. *)
 184   fs_is_swap : bool;                    (* If swap, following not valid. *)
 185   fs_blocks_reserved : int64;           (* Blocks reserved for super-user. *)
 186   fs_blocks_avail : int64;              (* Blocks free (available). *)
 187   fs_blocks_used : int64;               (* Blocks in use. *)
 188   fs_inodes_total : int64;              (* Total inodes. *)
 189   fs_inodes_reserved : int64;           (* Inodes reserved for super-user. *)
 190   fs_inodes_avail : int64;              (* Inodes free (available). *)
 191   fs_inodes_used : int64;               (* Inodes in use. *)
 192 }
 193
 194 (* Convert partition, filesystem types to printable strings for debugging. *)
 195 let string_of_partition
 196     { part_status = status; part_type = typ; part_dev = dev } =
 197   sprintf "%s: %s partition type %d"
 198     dev#name
 199     (match status with
 200      | Bootable -> "bootable"
 201      | Nonbootable -> "nonbootable"
 202      | Malformed -> "malformed"
 203      | NullEntry -> "empty")
 204     typ
 205
 206 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
 207   if not swap then name
 208   else name ^ " [swap]"
 209
 210 (* Register a partition scheme. *)
 211 let partition_types = ref []
 212 let partition_type_register (parts_name : string) probe_fn =
 213   partition_types := (parts_name, probe_fn) :: !partition_types
 214
 215 (* Probe a device for partitions.  Returns [Some parts] or [None]. *)
 216 let probe_for_partitions dev =
 217   if debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
 218   let rec loop = function
 219     | [] -> None
 220     | (parts_name, probe_fn) :: rest ->
 221         try Some (probe_fn dev)
 222         with Not_found -> loop rest
 223   in
 224   let r = loop !partition_types in
 225   if debug then (
 226     match r with
 227     | None -> eprintf "no partitions found on %s\n%!" dev#name
 228     | Some { parts_name = name; parts = parts } ->
 229         eprintf "found %d %s partitions on %s:\n"
 230           (List.length parts) name dev#name;
 231         List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
 232   );
 233   r
 234
 235 (* Register a filesystem type (or swap). *)
 236 let filesystem_types = ref []
 237 let filesystem_type_register (fs_name : string) probe_fn =
 238   filesystem_types := (fs_name, probe_fn) :: !filesystem_types
 239
 240 (* Probe a device for filesystems.  Returns [Some fs] or [None]. *)
 241 let probe_for_filesystems dev =
 242   if debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
 243   let rec loop = function
 244     | [] -> None
 245     | (fs_name, probe_fn) :: rest ->
 246         try Some (probe_fn dev)
 247         with Not_found -> loop rest
 248   in
 249   let r = loop !filesystem_types in
 250   if debug then (
 251     match r with
 252     | None -> eprintf "no filesystem found on %s\n%!" dev#name
 253     | Some fs ->
 254         eprintf "found a filesystem on %s:\n" dev#name;
 255         eprintf "\t%s\n%!" (string_of_filesystem fs)
 256   );
 257   r
 258
 259 (* Register a volume management type. *)
 260 (*
 261 let lvm_types = ref []
 262 let lvm_type_register (lvm_name : string) probe_fn =
 263   lvm_types := (lvm_name, probe_fn) :: !lvm_types
 264 *)
 265
 266 (*----------------------------------------------------------------------*)
 267
 268 let main () =
 269   (* Command line argument parsing. *)
 270   let set_uri = function "" -> uri := None | u -> uri := Some u in
 271
 272   let version () =
 273     printf "virt-df %s\n" (Libvirt_version.version);
 274
 275     let major, minor, release =
 276       let v, _ = Libvirt.get_version () in
 277       v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
 278     printf "libvirt %d.%d.%d\n" major minor release;
 279     exit 0
 280   in
 281
 282   let test_mode filename =
 283     test_files := filename :: !test_files
 284   in
 285
 286   let argspec = Arg.align [
 287     "-a", Arg.Set all,
 288       " " ^ s_ "Show all domains (default: only active domains)";
 289     "--all", Arg.Set all,
 290       " " ^ s_ "Show all domains (default: only active domains)";
 291     "-c", Arg.String set_uri,
 292       "uri " ^ s_ "Connect to URI (default: Xen)";
 293     "--connect", Arg.String set_uri,
 294       "uri " ^ s_ "Connect to URI (default: Xen)";
 295     "-h", Arg.Set human,
 296       " " ^ s_ "Print sizes in human-readable format";
 297     "--human-readable", Arg.Set human,
 298       " " ^ s_ "Print sizes in human-readable format";
 299     "-i", Arg.Set inodes,
 300       " " ^ s_ "Show inodes instead of blocks";
 301     "--inodes", Arg.Set inodes,
 302       " " ^ s_ "Show inodes instead of blocks";
 303     "-t", Arg.String test_mode,
 304       "dev" ^ s_ "(Test mode) Display contents of block device or file";
 305     "--version", Arg.Unit version,
 306       " " ^ s_ "Display version and exit";
 307   ] in
 308
 309   let anon_fun str =
 310     raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in
 311   let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests
 312
 313 SUMMARY
 314   virt-df [-options]
 315
 316 OPTIONS" in
 317
 318   Arg.parse argspec anon_fun usage_msg;
 319
 320   let doms : domain list =
 321     if !test_files = [] then (
 322       let xmls =
 323         (* Connect to the hypervisor. *)
 324         let conn =
 325           let name = !uri in
 326           try C.connect_readonly ?name ()
 327           with
 328             Libvirt.Virterror err ->
 329               prerr_endline (Libvirt.Virterror.to_string err);
 330               (* If non-root and no explicit connection URI, print a warning. *)
 331               if geteuid () <> 0 && name = None then (
 332                 print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root");
 333               );
 334               exit 1 in
 335
 336         (* Get the list of active & inactive domains. *)
 337         let doms =
 338           let nr_active_doms = C.num_of_domains conn in
 339           let active_doms =
 340             Array.to_list (C.list_domains conn nr_active_doms) in
 341           let active_doms =
 342             List.map (D.lookup_by_id conn) active_doms in
 343           if not !all then
 344             active_doms
 345           else (
 346             let nr_inactive_doms = C.num_of_defined_domains conn in
 347             let inactive_doms =
 348               Array.to_list (C.list_defined_domains conn nr_inactive_doms) in
 349             let inactive_doms =
 350               List.map (D.lookup_by_name conn) inactive_doms in
 351             active_doms @ inactive_doms
 352           ) in
 353
 354         (* Get their XML. *)
 355         let xmls = List.map D.get_xml_desc doms in
 356
 357         (* Parse the XML. *)
 358         let xmls = List.map Xml.parse_string xmls in
 359
 360         (* Return just the XML documents - everything else will be closed
 361          * and freed including the connection to the hypervisor.
 362          *)
 363         xmls in
 364
 365       (* Grr.. Need to use a library which has XPATH support (or cduce). *)
 366       List.map (
 367         fun xml ->
 368           let nodes, domain_attrs =
 369             match xml with
 370             | Xml.Element ("domain", attrs, children) -> children, attrs
 371             | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
 372
 373           let domid =
 374             try Some (int_of_string (List.assoc "id" domain_attrs))
 375             with Not_found -> None in
 376
 377           let rec loop = function
 378             | [] ->
 379                 failwith (s_ "get_xml_desc returned no <name> node in XML")
 380             | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name
 381             | Xml.Element ("name", _, _) :: _ ->
 382                 failwith (s_ "get_xml_desc returned strange <name> node")
 383             | _ :: rest -> loop rest
 384           in
 385           let name = loop nodes in
 386
 387           let devices =
 388             let devices =
 389               List.filter_map (
 390                 function
 391                 | Xml.Element ("devices", _, devices) -> Some devices
 392                 | _ -> None
 393               ) nodes in
 394             List.concat devices in
 395
 396           let rec target_dev_of = function
 397             | [] -> None
 398             | Xml.Element ("target", attrs, _) :: rest ->
 399                 (try Some (List.assoc "dev" attrs)
 400                  with Not_found -> target_dev_of rest)
 401             | _ :: rest -> target_dev_of rest
 402           in
 403
 404           let rec source_file_of = function
 405             | [] -> None
 406             | Xml.Element ("source", attrs, _) :: rest ->
 407                 (try Some (List.assoc "file" attrs)
 408                  with Not_found -> source_file_of rest)
 409             | _ :: rest -> source_file_of rest
 410           in
 411
 412           let rec source_dev_of = function
 413             | [] -> None
 414             | Xml.Element ("source", attrs, _) :: rest ->
 415                 (try Some (List.assoc "dev" attrs)
 416                  with Not_found -> source_dev_of rest)
 417             | _ :: rest -> source_dev_of rest
 418           in
 419
 420           let disks =
 421             List.filter_map (
 422               function
 423               | Xml.Element ("disk", attrs, children) ->
 424                   let typ =
 425                     try Some (List.assoc "type" attrs)
 426                     with Not_found -> None in
 427                   let device =
 428                     try Some (List.assoc "device" attrs)
 429                     with Not_found -> None in
 430                   let source =
 431                     match source_file_of children with
 432                     | (Some _) as source -> source
 433                     | None -> source_dev_of children in
 434                   let target = target_dev_of children in
 435
 436                   (* We only care about devices where we have
 437                    * source and target.  Ignore CD-ROM devices.
 438                    *)
 439                   (match source, target, device with
 440                    | _, _, Some "cdrom" -> None (* ignore *)
 441                    | Some source, Some target, Some device ->
 442                        (* Try to create a 'device' object for this
 443                         * device.  If it fails, print a warning
 444                         * and ignore the device.
 445                         *)
 446                        (try
 447                           let dev = new block_device source in
 448                           Some {
 449                             d_type = typ; d_device = device;
 450                             d_source = source; d_target = target;
 451                             d_dev = dev; d_content = `Unknown
 452                           }
 453                         with
 454                           Unix_error (err, func, param) ->
 455                             eprintf "%s:%s: %s" func param (error_message err);
 456                             None
 457                        )
 458                    | _ -> None (* ignore anything else *)
 459                   )
 460
 461               | _ -> None
 462             ) devices in
 463
 464           { dom_name = name; dom_id = domid; dom_disks = disks }
 465       ) xmls
 466     ) else (
 467       (* In test mode (-t option) the user can pass one or more
 468        * block devices or filenames (containing partitions/filesystems/etc)
 469        * which we use for testing virt-df itself.  We create fake domains
 470        * from these.
 471        *)
 472       List.map (
 473         fun filename ->
 474           {
 475             dom_name = filename; dom_id = None;
 476             dom_disks = [
 477               {
 478                 d_type = Some "disk"; d_device = "disk";
 479                 d_source = filename; d_target = "hda";
 480                 d_dev = new block_device filename; d_content = `Unknown;
 481               }
 482             ]
 483           }
 484       ) !test_files
 485     ) in
 486
 487   (* HOF to map over disks. *)
 488   let map_over_disks doms f =
 489     List.map (
 490       fun ({ dom_disks = disks } as dom) ->
 491         let disks = List.map f disks in
 492         { dom with dom_disks = disks }
 493     ) doms
 494   in
 495
 496   (* 'doms' is our list of domains and their guest block devices, and
 497    * we've successfully opened each block device.  Now probe them
 498    * to find out what they contain.
 499    *)
 500   let doms = map_over_disks doms (
 501     fun ({ d_dev = dev } as disk) ->
 502       (* See if it is partitioned first. *)
 503       let parts = probe_for_partitions dev in
 504       match parts with
 505       | Some parts ->
 506           { disk with d_content = `Partitions parts }
 507       | None ->
 508           (* Not partitioned.  Does it contain a filesystem? *)
 509           let fs = probe_for_filesystems dev in
 510           match fs with
 511           | Some fs ->
 512               { disk with d_content = `Filesystem fs }
 513           | None ->
 514               (* Not partitioned, no filesystem, so it's spare. *)
 515               disk
 516   ) in
 517
 518   (* Now we have either detected partitions or a filesystem on each
 519    * physical device (or perhaps neither).  See what is on those
 520    * partitions.
 521    *)
 522   let doms = map_over_disks doms (
 523     function
 524     | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
 525         let ps = List.map (
 526           fun p ->
 527             if p.part_status = Bootable || p.part_status = Nonbootable then (
 528               let fs = probe_for_filesystems p.part_dev in
 529               match fs with
 530               | Some fs ->
 531                   { p with part_content = `Filesystem fs }
 532               | None ->
 533                   p
 534             ) else p
 535         ) parts.parts in
 536         let parts = { parts with parts = ps } in
 537         { disk with d_content = `Partitions parts }
 538     | disk -> disk
 539   ) in
 540
 541   (* XXX LVM stuff here. *)
 542
 543
 544
 545   (* Print the title. *)
 546   let () =
 547     let total, used, avail =
 548       match !inodes, !human with
 549       | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available"
 550       | false, true -> s_ "Size", s_ "Used", s_ "Available"
 551       | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in
 552     printf "%-20s %10s %10s %10s %s\n%!"
 553       (s_ "Filesystem") total used avail (s_ "Type") in
 554
 555   let printable_size bytes =
 556     if bytes < 1024L *^ 1024L then
 557       sprintf "%Ld bytes" bytes
 558     else if bytes < 1024L *^ 1024L *^ 1024L then
 559       sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.)
 560     else
 561       sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.)
 562   in
 563
 564   (* HOF to iterate over filesystems. *)
 565   let iter_over_filesystems doms f =
 566     List.iter (
 567       fun ({ dom_disks = disks } as dom) ->
 568         List.iter (
 569           function
 570           | ({ d_content = `Filesystem fs } as disk) ->
 571               f dom disk None fs
 572           | ({ d_content = `Partitions partitions } as disk) ->
 573               List.iteri (
 574                 fun i ->
 575                   function
 576                   | ({ part_content = `Filesystem fs } as part) ->
 577                       f dom disk (Some (part, i)) fs
 578                   | _ -> ()
 579               ) partitions.parts
 580           | _ -> ()
 581         ) disks
 582     ) doms
 583   in
 584
 585   (* Print stats for each recognized filesystem. *)
 586   let print_stats dom disk part fs =
 587     (* Printable name is like "domain:hda" or "domain:hda1". *)
 588     let name =
 589       let dom_name = dom.dom_name in
 590       let d_target = disk.d_target in
 591       match part with
 592       | None ->
 593           dom_name ^ ":" ^ d_target
 594       | Some (_, pnum) ->
 595           dom_name ^ ":" ^ d_target ^ string_of_int pnum in
 596     printf "%-20s " name;
 597
 598     if fs.fs_is_swap then (
 599       (* Swap partition. *)
 600       if not !human then
 601         printf "%10Ld                       %s\n"
 602           (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
 603       else
 604         printf "%10s                       %s\n"
 605           (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
 606     ) else (
 607       (* Ordinary filesystem. *)
 608       if not !inodes then (             (* Block display. *)
 609         (* 'df' doesn't count the restricted blocks. *)
 610         let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
 611         let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
 612         let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
 613
 614         if not !human then (            (* Display 1K blocks. *)
 615           printf "%10Ld %10Ld %10Ld %s\n"
 616             (blocks_total *^ fs.fs_block_size /^ 1024L)
 617             (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
 618             (blocks_avail *^ fs.fs_block_size /^ 1024L)
 619             fs.fs_name
 620         ) else (                        (* Human-readable blocks. *)
 621           printf "%10s %10s %10s %s\n"
 622             (printable_size (blocks_total *^ fs.fs_block_size))
 623             (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
 624             (printable_size (blocks_avail *^ fs.fs_block_size))
 625             fs.fs_name
 626         )
 627       ) else (                          (* Inodes display. *)
 628         printf "%10Ld %10Ld %10Ld %s\n"
 629           fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
 630           fs.fs_name
 631       )
 632     )
 633   in
 634   iter_over_filesystems doms print_stats
 635
 636 (*
 637 (* Probe a single partition, which we assume contains either a
 638  * filesystem or is a PV.
 639  * - target will be something like "hda" or "hda1"
 640  * - part_type will be the partition type if known, or None
 641  * - fd is a file descriptor opened on the device
 642  * - start & size are where we think the start and size of the
 643  *   partition is within the file descriptor (in SECTORS)
 644  *)
 645 and probe_partition target part_type fd start size =
 646   match part_type with
 647   | None ->
 648       ProbeFailed (s_ "detection of unpartitioned devices not yet supported")
 649   | Some 0x05 ->
 650       ProbeIgnore (* Extended partition - ignore it. *)
 651   | Some part_type ->
 652       try
 653         let probe_fn = Hashtbl.find filesystems part_type in
 654         probe_fn target part_type fd start size
 655       with
 656         Not_found ->
 657           ProbeFailed
 658             (sprintf (f_ "unsupported partition type %02x") part_type)
 659 *)