(* virt-ctrl: A graphical management tool.
   (C) Copyright 2007 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
open ExtList
open Xml

open Virt_ctrl_gettext.Gettext

let (//) = Filename.concat

type virt_type =
  | VT_HVM | VT_Xen | UnknownVirtType
type arch =
  | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
  | OtherArch of string
  | UnknownArch
type hv_name =				(* implicitly ordered worst->best *)
  | UnknownHVType | QEMU | Xen | KVM

(* List of supported distros.  The name field must be unique but
 * doesn't need to be constant.
 *)
let distros = [
  "Fedora 8 (i386, 32 bit, Xen paravirtualized)", (
    VT_Xen, I386
  );
  "Fedora 8 (i386, 32 bit, fully virtualized)", (
    VT_HVM, I386
  );
  "Fedora 8 (x86-64, 64 bit, Xen paravirtualized)", (
    VT_Xen, X86_64
  );
  "Fedora 8 (x86-64, 64 bit, fully virtualized)", (
    VT_HVM, X86_64
  );
  "Fedora 9 (i386, 32 bit, Xen paravirtualized)", (
    VT_Xen, I386
  );
  "Fedora 9 (i386, 32 bit, fully virtualized)", (
    VT_HVM, I386
  );
  "Fedora 9 (x86-64, 64 bit, Xen paravirtualized)", (
    VT_Xen, X86_64
  );
  "Fedora 9 (x86-64, 64 bit, fully virtualized)", (
    VT_HVM, X86_64
  );
]

let string_of_virt_type = function
  | VT_HVM -> "hvm"
  | VT_Xen -> "xen"
  | UnknownVirtType -> invalid_arg "string_of_virt_type"

let string_of_architecture = function
  | I386 -> "i386"
  | X86_64 -> "x86_64"
  | IA64 -> "ia64"
  | PPC -> "ppc"
  | PPC64 -> "ppc64"
  | SPARC -> "sparc"
  | SPARC64 -> "sparc64"
  | OtherArch arch -> arch
  | UnknownArch -> invalid_arg "string_of_architecture"

let architecture_of_string = function
  | str when
      String.length str = 4 &&
      (str.[0] = 'i' || str.[0] = 'I') &&
      (str.[1] >= '3' && str.[1] <= '6') &&
      str.[2] = '8' && str.[3] = '6' -> I386
  | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
  | "ia64" | "IA64" -> IA64
  | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
  | "ppc64" | "PPC64" -> PPC64
  | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
  | "sparc64" | "SPARC64" -> SPARC64
  | str -> OtherArch str

let string_of_hv_name = function
  | Xen -> "Xen"
  | QEMU -> "QEMU"
  | KVM -> "KVM"
  | UnknownHVType -> "unknown"

(* Choose a disk location for images.
 * This changed in libvirt 0.4.something.
 *)
let disk_location =
  let dirs = [
    "/var/lib/libvirt/images";
    "/var/lib/libvirt/xen";
  ] in
  let dirs =
    try dirs @ [Sys.getenv "HOME"]
    with Not_found -> dirs in
  try
    List.find (
      fun d ->
	try (stat d).st_kind = S_DIR
	with Unix_error _ -> false
    ) dirs
  with
    Not_found -> "/var/tmp"

type edit_status = UserEdit | ProgramEdit | Disconnected

let rec find_map f = function
  | [] -> raise Not_found
  | x :: xs ->
      match f x with
      | Some y -> y
      | None -> find_map f xs

(* Install guest dialog. *)
let rec install_guest parent conn_id () =
  let title = s_"Install new guest" in
  let position = `CENTER_ON_PARENT in

  let dlg = GWindow.dialog ~title ~position ~parent ~modal:true () in

  (* We will enter the Gtk main loop recursively.  Wire up close and
   * other buttons to quit the recursive main loop.
   *)
  ignore (dlg#connect#destroy ~callback:GMain.quit);
  ignore (dlg#event#connect#delete
	    ~callback:(fun _ -> GMain.quit (); false));

  (* Action area. *)
  let cancel_button =
    GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
  ignore (cancel_button#connect#clicked ~callback:dlg#destroy);

  let install_button =
    GButton.button ~label:(s_"Install") ~packing:dlg#action_area#pack () in

  (* Connections. *)
  let conns = get_connections () in

  let frame =
    GBin.frame ~label:(s_"Hypervisor connection")
      ~packing:dlg#vbox#pack () in
  let hbox = GPack.hbox ~packing:frame#add () in

  ignore (GMisc.label ~text:(s_"Connection:") ~xalign:1.0
	    ~packing:hbox#pack ());

  let conn_combo, (conn_model : GTree.list_store), conn_col_id, conn_active =
    populate_conns conns hbox#pack conn_id in

  (* Distro. *)
  let frame =
    GBin.frame ~label:(s_"Operating system") ~packing:dlg#vbox#pack () in

  let (distro_combo, (distro_list, distro_col_name)) =
    GEdit.combo_box_text ~packing:frame#add () in

  (* VM name. *)
  let frame =
    GBin.frame ~label:(s_"Guest details") ~packing:dlg#vbox#pack () in

  let tbl = GPack.table ~columns:3 ~rows:5 ~packing:frame#add () in

  ignore (GMisc.label ~text:(s_"Name:") ~xalign:1.0
	    ~packing:(tbl#attach ~top:0 ~left:0) ());
  let name_entry =
    GEdit.entry ~width_chars:32
      ~packing:(tbl#attach ~top:0 ~left:1) () in

  (* Disk image. *)
  ignore (GMisc.label ~text:(s_"Disk image:") ~xalign:1.0
	    ~packing:(tbl#attach ~top:1 ~left:0) ());
  let disk_entry =
    GEdit.entry ~width_chars:48
      ~packing:(tbl#attach ~top:1 ~left:1) () in
  let hbox = GPack.hbox ~packing:(tbl#attach ~top:1 ~left:2) () in
  let disk_size =
    GEdit.spin_button ~numeric:true ~digits:1
      ~packing:hbox#pack () in
  disk_size#adjustment#set_bounds ~lower:2.0 ~upper:999.0 ~step_incr:0.5 ();
  disk_size#adjustment#set_value 8.0;
  ignore (GMisc.label ~text:" GB" ~packing:hbox#pack ());

  (* Network. *)
  ignore (GMisc.label ~text:(s_"Network:") ~xalign:1.0
	    ~packing:(tbl#attach ~top:2 ~left:0) ());
  let (net_combo, _) =
    GEdit.combo_box_text
      ~strings:["default"] (* XXX not implemented *)
      ~packing:(tbl#attach ~top:2 ~left:1) () in
  net_combo#set_active 0;

  (* RAM. *)
  ignore (GMisc.label ~text:(s_"RAM:") ~xalign:1.0
	    ~packing:(tbl#attach ~top:3 ~left:0) ());
  let hbox = GPack.hbox ~packing:(tbl#attach ~top:3 ~left:1) () in
  let ram =
    GEdit.spin_button ~numeric:true ~digits:0
      ~packing:hbox#pack () in
  ram#adjustment#set_bounds ~lower:128.0 ~upper:131_072.0 ~step_incr:32.0 ();
  ram#adjustment#set_value 512.0;
  ignore (GMisc.label ~text:" MB" ~packing:hbox#pack ());

  (* CPUs. *)
  ignore (GMisc.label ~text:(s_"CPUs:") ~xalign:1.0
	    ~packing:(tbl#attach ~top:4 ~left:0) ());
  let hbox = GPack.hbox ~packing:(tbl#attach ~top:4 ~left:1) () in
  let vcpus =
    GEdit.spin_button ~numeric:true ~digits:0
      ~packing:hbox#pack () in
  vcpus#adjustment#set_bounds ~lower:1.0 ~upper:4.0 ~step_incr:1.0 ();
  vcpus#adjustment#set_value 1.0;

  let () =
    (* When connection combo changes we need to repopulate list of distros. *)
    ignore (
      conn_combo#connect#changed
	~callback:(
	  fun () ->
	    repopulate_distros conns conn_combo conn_model conn_col_id
	      distro_combo distro_list distro_col_name
	)
    );

    (* When distro changes we need to change the name, provided the name
     * hasn't been edited by the user (in which case we leave it alone).
     *
     * We have to use a shared reference so that we don't disconnect
     * the signal when we are editing the field (not the user).  Ugh ...
     *)
    let edit_status = ref UserEdit in
    let distro_changed_id =
      distro_combo#connect#changed
	~callback:(
	  fun () ->
	    let row = distro_combo#active_iter in
	    match row with
	    | None -> ()		(* no distro selected *)
	    | Some row ->
		let name = distro_list#get ~row ~column:distro_col_name in
		let name = short_name_of_distro name in

		let old_status = !edit_status in
		edit_status := ProgramEdit;
		name_entry#set_text name;
		disk_entry#set_text (disk_location // name ^ ".img");
		edit_status := old_status
	) in

    ignore (
      name_entry#connect#changed ~callback:(
	fun () ->
	  if !edit_status = UserEdit then (
	    distro_combo#misc#disconnect distro_changed_id;
	    edit_status := Disconnected	(* prevent multiple disconnections *)
	  )
      )
    );

    ignore (
      disk_entry#connect#changed ~callback:(
	fun () ->
	  if !edit_status = UserEdit then (
	    distro_combo#misc#disconnect distro_changed_id;
	    edit_status := Disconnected	(* prevent multiple disconnections *)
	  )
      )
    );

    (* Wire up the install button. *)
    ignore (
      install_button#connect#clicked ~callback:(
	fun () ->
	  (* Get the required settings. *)
	  let conn_id =
	    match conn_combo#active_iter with
	    | None ->			(* no connection selected *)
		invalid_arg (s_"No connection selected")
	    | Some row ->
		conn_model#get ~row ~column:conn_col_id in
	  let distro =
	    match distro_combo#active_iter with
	    | None ->			(* no distro selected *)
		invalid_arg (s_"No operating system selected")
	    | Some row ->
		distro_list#get ~row ~column:distro_col_name in
	  let name = name_entry#text in
	  let disk = disk_entry#text in
	  let disk_size = disk_size#value in
	  let net = "default" (* XXX network not implemented *) in
	  let ram = ram#value_as_int in
	  let vcpus = vcpus#value_as_int in

	  dlg#destroy ();
	  start_install parent conns
	    conn_id distro name disk disk_size net ram vcpus
      )
    ) in

  (* See combobox.ml example in %doc directory.
   * NB. Don't use ~active label above.  It is buggy and won't trigger
   * the selection callback.
   *)
  conn_combo#set_active conn_active;

  (* Set focus on the distro. *)
  distro_combo#misc#grab_focus ();

  dlg#show ();

  (* Enter Gtk main loop recursively. *)
  GMain.main ()

(* Populate the list of connections. *)
and populate_conns conns packing conn_id =
  (* Model/columns. *)
  let cols = new GTree.column_list in
  let col_name = cols#add Gobject.Data.string in
  let col_id = cols#add Gobject.Data.int in
  let model = GTree.list_store cols in

  (* View. *)
  let conn_combo = GEdit.combo_box ~model ~packing () in

  let renderer = GTree.cell_renderer_text [] in
  conn_combo#pack renderer;
  ignore (conn_combo#add_attribute renderer "text" col_name);

  (* Populate the connection combo box. *)
  let active = ref 0 in
  List.iteri (
    fun i (id, (conn, hostname, guests)) ->
      if id = conn_id then active := i;

      let name =
	(* Get unique list of all HV types supported. *)
	let hvs = List.map (fun (_, _, domains) -> domains) guests in
	let hvs = List.concat hvs in
	let hvs = List.map fst hvs in
	let hvs = List.unique hvs in
	let hvs = List.sort hvs in

	(* Make a printable string for this connection. *)
	sprintf "%s (%s)" hostname
	  (String.concat "/" (List.map string_of_hv_name hvs)) in

      let row = model#append () in
      model#set ~row ~column:col_name name;
      model#set ~row ~column:col_id conn_id
  ) conns;

  conn_combo, model, col_id, !active

(* When connection combo selection changes, repopulate list of distros. *)
and repopulate_distros conns conn_combo conn_model conn_col_id
    distro_combo distro_list distro_col_name =
  (* Clear the distro list. *)
  distro_list#clear ();

  let row = conn_combo#active_iter in
  match row with
  | None -> ()				(* no connection selected *)
  | Some row ->
      let conn_id = conn_model#get ~row ~column:conn_col_id in
      let conn, hostname, guests = List.assoc conn_id conns in

      (* Get the distros which match one of the guest types. *)
      let distros = List.map get_matching_distros guests in
      let distros = List.concat distros in
      let distros = List.unique distros in
      let distros = List.sort distros in

      (* Populate the list with distros which match. *)
      List.iter (
	fun (name, _) ->
	  let row = distro_list#append () in
	  distro_list#set ~row ~column:distro_col_name name
      ) distros;

      if List.length distros > 0 then distro_combo#set_active 0

and get_matching_distros (virt_type, arch, domains) =
  List.filter (
    fun (_, (virt_type', arch')) ->
      virt_type = virt_type' && arch = arch'
  ) distros

(* Get a short name from the selected distro's name. *)
and short_name_of_distro name =
  let len = String.length name in
  let buf = Buffer.create 16 in
  let rec loop i =
    if i < len then (
      let c = name.[i] in
      match c with
      | 'A' .. 'Z' ->
	  Buffer.add_char buf (Char.chr (Char.code c + 0x20));
	  loop (i+1)
      | 'a' .. 'z' | '0' .. '9' ->
	  Buffer.add_char buf c;
	  loop (i+1)
      | '(' -> ()			(* stop at first '(' character *)
      | _ -> loop (i+1)
    )
  in
  loop 0;
  Buffer.contents buf

(* Get connection details, mainly from the capabilities XML. *)
and get_connections () =
  let conns = Vc_connections.get_conns () in
  List.map (
    fun (conn_id, conn) ->
      let hostname =
	match Vc_connections.get_hostname conn_id with
	| Some hostname -> hostname
	| None -> sprintf "Conn #%d" conn_id in

      (* Get some idea of what the hypervisor supports. *)
      let guests =
	let caps = Vc_connections.get_capabilities conn_id in
	match caps with
	| Some (Element ("capabilities", _, children)) ->
	    List.filter_map (
	      function
	      | Element ("guest", _, children) -> Some children
	      | _ -> None
	    ) children
	| _ -> [] in		 (* XXX should do better if no caps *)

      let guests =
	List.map (
	  fun guest ->
	    let os_type =
	      try
		find_map (
		  function
		  | Element ("os_type", _, [PCData "hvm"]) -> Some VT_HVM
		  | Element ("os_type", _, [PCData "xen"]) -> Some VT_Xen
		  | _ -> None
		) guest
	      with
		Not_found -> UnknownVirtType in

	    let arch, domains =
	      try
		find_map (
		  function
		  | Element ("arch", attrs, children) ->
		      let arch =
			try architecture_of_string (List.assoc "name" attrs)
			with Not_found -> UnknownArch in
		      let domains =
			List.filter_map (
			  function
			  | Element ("domain", attrs, children) ->
			      let domtype =
				try
				  match List.assoc "type" attrs with
				  | "xen" -> Xen
				  | "qemu" -> QEMU
				  | "kvm" -> KVM
				  | _ -> UnknownHVType
				with Not_found -> UnknownHVType in
			      Some (domtype, children)
			  | _ -> None
			) children in
		      Some (arch, domains)
		  | _ -> None
		) guest
	      with
		Not_found -> UnknownArch, [] in

	    (os_type, arch, domains)
	) guests in

      (conn_id, (conn, hostname, guests))
  ) conns

(* Perform (or at least start off) the install. *)
and start_install parent conns
    conn_id distro name disk disk_size net ram vcpus =
  (* Create new toplevel dialog to show the progress of the steps. *)
  let title = s_"Guest installing" in
  let position = `CENTER_ON_PARENT in

  let dlg = GWindow.dialog
    ~title ~position ~parent ~modal:false ~width:480 () in

  let frame =
    GBin.frame ~label:(s_ "Download kernel") ~packing:dlg#vbox#pack () in
  let kernel_bar = GRange.progress_bar ~packing:frame#add () in

  let frame =
    GBin.frame ~label:(s_ "Download initrd") ~packing:dlg#vbox#pack () in
  let initrd_bar = GRange.progress_bar ~packing:frame#add () in

  let frame =
    GBin.frame ~label:(s_ "Create disk image") ~packing:dlg#vbox#pack () in
  let disk_bar = GRange.progress_bar ~packing:frame#add () in

  (* We will enter the Gtk main loop recursively.  Wire up close and
   * other buttons to quit the recursive main loop.
   *)
  ignore (dlg#connect#destroy ~callback:GMain.quit);
  ignore (dlg#event#connect#delete
	    ~callback:(fun _ -> GMain.quit (); false));

  (* Action area. *)
  let cancel_button =
    GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
  ignore (cancel_button#connect#clicked ~callback:dlg#destroy);

(*
  (* Create the disk image if necessary.
   * XXX Should have checked earlier if it already exists.
   *)
  let disk_exists =
    try (stat disk).st_kind = S_REG
    with Unix_error _ -> false in
  if not disk_exists then (
    try
      let fd = openfile disk [O_WRONLY;O_CREAT] in
      let onemeg = 1024*1024 in
      let buffer = String.make onemeg '\000' in
      let nmegs = int_of_float (disk_size *. 1024.) in
      for i = 0 to nmegs-1 do
	write fd buffer 0 onemeg
      done;
      close fd
    with
      exn ->
	(* Remove the disk image. *)
	(try unlink disk with _ -> ());
	(* Re-raise the original exception. *)
	raise exn
  );
*)

  (* Get the distro by name. *)
  let virt_type, arch = List.assoc distro distros in

  (* Generate the XML configuration. *)
  let xml =
    (* Shortcut to make "<name>value</name>". *)
    let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
    (* ... and the _other_ sort of leaf (god I hate XML). *)
    let tleaf name attribs = Xml.Element (name, attribs, []) in

    (* Standard stuff for every domain. *)
    let name = leaf "name" name in
    let uuid = leaf "uuid" (random_uuid ()) in
    let maxmem, memory =
      let m = string_of_int (ram * 1024) in
      leaf "maxmem" m, leaf "memory" m in
    let vcpus = leaf "vcpu" (string_of_int vcpus) in

    (* <os> section, describes kernel, boot locations. *)




    (* Put it all together in <domain type='foo'>. *)
    Xml.Element (
      "domain",
      [ "type", string_of_virt_type virt_type ],
      name :: uuid :: memory :: maxmem :: vcpus :: []
    ) in

  let xml = Xml.to_string_fmt xml in

  prerr_endline xml;

  dlg#show ();

  (* Enter Gtk main loop recursively. *)
  GMain.main ()

(* Generate a random MAC address in the Xen-reserved space. *)
and random_mac_address () =
  let random =
    List.map (sprintf "%02x") (
      List.map (fun _ -> Random.int 256) [0;0;0]
    ) in
  String.concat ":" ("00"::"16"::"3e"::random)

(* Generate a random UUID. *)
and random_uuid =
  let hex = "0123456789abcdef" in
  fun () ->
  let str = String.create 32 in
  for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;
  str