(* Diskimage library for reading disk images.
   (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
   http://libvirt.org/

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *)

open Printf
open Unix

let debug = ref false

let ( +* ) = Int32.add
let ( -* ) = Int32.sub
let ( ** ) = Int32.mul
let ( /* ) = Int32.div

let ( +^ ) = Int64.add
let ( -^ ) = Int64.sub
let ( *^ ) = Int64.mul
let ( /^ ) = Int64.div

class virtual device =
object (self)
  method virtual read : int64 -> int -> string
  method virtual size : int64
  method virtual name : string

  method close () = ()

  (* Helper method to read a chunk of data into a bitstring. *)
  method read_bitstring offset len =
    let str = self#read offset len in
    (str, 0, len * 8)
end

(* A concrete device which just direct-maps a file or /dev device. *)
class block_device filename =
  let fd = openfile filename [ O_RDONLY ] 0 in
  let size = (LargeFile.fstat fd).LargeFile.st_size in
object (self)
  inherit device
  method read offset len =
    ignore (LargeFile.lseek fd offset SEEK_SET);
    let str = String.make len '\000' in
    read fd str 0 len;
    str
  method close () = close fd
  method size = size
  method name = filename
end

(* A linear offset/size from an underlying device. *)
class offset_device name start size (dev : device) =
object
  inherit device
  method name = name
  method size = size
  (* method close () = dev#close () - NB: NO!!  Device may be shared. *)
  method read offset len =
    if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
      invalid_arg (
	sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
	  name offset len size
      );
    dev#read (start+^offset) len
end

(* The null device.  Any attempt to read generates an error. *)
let null_device : device =
object
  inherit device
  method read _ _ = assert false
  method size = 0L
  method name = "null"
end

type machine = {
  m_name : string;			(* Machine name. *)
  m_disks : disk list;			(* Machine disks. *)
  m_lv_filesystems :
    (lv * filesystem) list;		(* Machine LV filesystems. *)
}
and disk = {
  d_name : string;			(* Device name (eg "hda") *)

  (* About the device itself. *)
  d_dev : device;			(* Disk device. *)
  d_content : disk_content;		(* What's on it. *)
}
and disk_content =
  [ `Unknown				(* Not probed or unknown. *)
  | `Partitions of partitions		(* Contains partitions. *)
  | `Filesystem of filesystem		(* Contains a filesystem directly. *)
  | `PhysicalVolume of pv		(* Contains an LVM PV. *)
  ]

(* Partitions. *)

and partitions = {
  parts_plugin_id : parts_plugin_id;	(* Partitioning scheme. *)
  parts : partition list		(* Partitions. *)
}
and partition = {
  part_status : partition_status;	(* Bootable, etc. *)
  part_type : int;			(* Partition filesystem type. *)
  part_dev : device;			(* Partition device. *)
  part_content : partition_content;	(* What's on it. *)
}
and partition_status = Bootable | Nonbootable | Malformed | NullEntry
and partition_content =
  [ `Unknown				(* Not probed or unknown. *)
  | `Filesystem of filesystem		(* Filesystem. *)
  | `PhysicalVolume of pv		(* Contains an LVM PV. *)
  ]

(* Filesystems (also swap devices). *)
and filesystem = {
  fs_plugin_id : fs_plugin_id;		(* Filesystem. *)
  fs_block_size : int64;		(* Block size (bytes). *)
  fs_blocks_total : int64;		(* Total blocks. *)
  fs_is_swap : bool;			(* If swap, following not valid. *)
  fs_blocks_reserved : int64;		(* Blocks reserved for super-user. *)
  fs_blocks_avail : int64;		(* Blocks free (available). *)
  fs_blocks_used : int64;		(* Blocks in use. *)
  fs_inodes_total : int64;		(* Total inodes. *)
  fs_inodes_reserved : int64;		(* Inodes reserved for super-user. *)
  fs_inodes_avail : int64;		(* Inodes free (available). *)
  fs_inodes_used : int64;		(* Inodes in use. *)
}

(* Physical volumes. *)
and pv = {
  lvm_plugin_id : lvm_plugin_id;        (* The LVM plug-in. *)
  pv_uuid : string;			(* UUID. *)
}

(* Logical volumes. *)
and lv = {
  lv_dev : device;			(* Logical volume device. *)
}

and parts_plugin_id = string
and fs_plugin_id = string
and lvm_plugin_id = string

(* Convert a UUID (containing '-' chars) to canonical form. *)
let canonical_uuid uuid =
  let uuid' = String.make 32 ' ' in
  let j = ref 0 in
  for i = 0 to String.length uuid - 1 do
    if !j >= 32 then invalid_arg "canonical_uuid";
    let c = uuid.[i] in
    if c <> '-' then ( uuid'.[!j] <- c; incr j )
  done;
  if !j <> 32 then invalid_arg "canonical_uuid";
  uuid'

(* This version by Isaac Trotts. *)
let group_by ?(cmp = Pervasives.compare) ls =
  let ls' =
    List.fold_left
      (fun acc (day1, x1) ->
         match acc with
             [] -> [day1, [x1]]
           | (day2, ls2) :: acctl ->
               if cmp day1 day2 = 0
               then (day1, x1 :: ls2) :: acctl
               else (day1, [x1]) :: acc)
      []
      ls
  in
  let ls' = List.rev ls' in
  List.map (fun (x, xs) -> x, List.rev xs) ls'

let rec range a b =
  if a < b then a :: range (a+1) b
  else []