# HG changeset patch # User Andrew Peace # Date 1263752616 0 # Node ID 8a6800752019e014066447b14c984d0077de7f0f # Parent b47a71895e80488da8797885935aec12921a246d [CP-1540] [CR-67] Remove P2V server components. Signed-off by: Andrew Peace diff -r b47a71895e80 -r 8a6800752019 OMakefile --- a/OMakefile Sun Jan 17 16:50:08 2010 +0000 +++ b/OMakefile Sun Jan 17 18:23:36 2010 +0000 @@ -117,8 +117,6 @@ ocaml/xsrpc/xsrpc \ ocaml/xsrpc/xsrpcd-util \ ocaml/guest/agent \ - ocaml/p2v/p2v \ - ocaml/p2v/closeandexec_static \ ocaml/license/v6testd \ ocaml/license/v6d-reopen-logs diff -r b47a71895e80 -r 8a6800752019 mk/Makefile --- a/mk/Makefile Sun Jan 17 16:50:08 2010 +0000 +++ b/mk/Makefile Sun Jan 17 18:23:36 2010 +0000 @@ -22,7 +22,6 @@ JQUERY_PACK_DIST = $(CARBON_DISTFILES)/javascript/jquery/jquery-1.1.3.1.pack.js JQUERY_TV_DIST = $(CARBON_DISTFILES)/javascript/jquery/treeview/jquery.treeview.zip -OUTPUT_P2V_DIR = $(MY_OUTPUT_DIR) OUTPUT_DATAMODEL_DIR = $(MY_OUTPUT_DIR)/datamodel OUTPUT_SDK_DIR = $(MY_OUTPUT_DIR) @@ -79,10 +78,6 @@ install -m 644 -o root -g root $(REPO)/ocaml/idl/dm_api.cmi $(OUTPUT_DATAMODEL_DIR) install -m 644 -o root -g root $(REPO)/ocaml/idl/api_messages.cmi $(OUTPUT_DATAMODEL_DIR) - mkdir -p $(OUTPUT_P2V_DIR) - install -m 755 -o root -g root $(REPO)/ocaml/p2v/p2v $(OUTPUT_P2V_DIR)/p2v-server - install -m 755 -o root -g root $(REPO)/ocaml/p2v/closeandexec_static $(OUTPUT_P2V_DIR)/closeandexec_static - $(RPM_SOURCESDIR)/xe: $(REPO)/ocaml/xe-cli/xe mkdir -p $(RPM_SOURCESDIR) cp $< $@ @@ -102,5 +97,5 @@ .PHONY: clean clean: rm -f $(OUTPUT_XAPI) $(OUTPUT_XAPI_DEVEL) $(OUTPUT_XAPI_SRC) $(OUTPUT_CLI_RT) $(OUTPUT_WEBZIP) $(OUTPUT_SDK) - rm -rf $(OUTPUT_DATAMODEL_DIR) $(OUTPUT_P2V_DIR) $(OUTPUT_DOCS) $(OUTPUT_SDK_DIR) + rm -rf $(OUTPUT_DATAMODEL_DIR) $(OUTPUT_DOCS) $(OUTPUT_SDK_DIR) $(MAKE) -C $(REPO) clean diff -r b47a71895e80 -r 8a6800752019 ocaml/OMakefile --- a/ocaml/OMakefile Sun Jan 17 16:50:08 2010 +0000 +++ b/ocaml/OMakefile Sun Jan 17 18:23:36 2010 +0000 @@ -26,7 +26,6 @@ auth \ events \ in_guest_install \ - p2v \ graph \ license \ rfb \ diff -r b47a71895e80 -r 8a6800752019 ocaml/p2v/OMakefile --- a/ocaml/p2v/OMakefile Sun Jan 17 16:50:08 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -OCAML_LIBS = ../util/version ../idl/ocaml_backend/common ../idl/ocaml_backend/client -OCAMLINCLUDES = ../idl/ocaml_backend ../idl ../autogen ../xapi -OCAMLPACKS = xml-light2 stdext stunnel http-svr log xs close-and-exec - -OCAMLFLAGS += -dtypes -warn-error F -cclib -static -cclib -lpthread -g - -OCamlProgram(p2v,p2v) - -section: - OCAMLFLAGS += -cclib -static - OCamlProgram(closeandexec_static, closeandexec_static) - -.PHONY: clean -clean: - rm -f $(CLEAN_OBJS) diff -r b47a71895e80 -r 8a6800752019 ocaml/p2v/closeandexec_static.ml --- a/ocaml/p2v/closeandexec_static.ml Sun Jan 17 16:50:08 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * 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 Lesser General Public License for more details. - *) - -include Closeandexec diff -r b47a71895e80 -r 8a6800752019 ocaml/p2v/p2v.ml --- a/ocaml/p2v/p2v.ml Sun Jan 17 16:50:08 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,789 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * 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 Lesser General Public License for more details. - *) -(*** - P2V SERVER - ***) - -open Pervasiveext -open Stringext -open Client -open Opt -open Unixext - -module D = Debug.Debugger(struct let name = "p2v" end) -open D - -let listen_addr = Unix.ADDR_INET(Unix.inet_addr_of_string "0.0.0.0", 81) - -let assert_dir path mode = - if not (Sys.file_exists path) then Unix.mkdir path mode - -type fs_metadata = { mounted_at : string } -type fs_metadata_hashtbl = (string, fs_metadata) Hashtbl.t -let new_fs_metadata mntpoint = { mounted_at = mntpoint } -let fs_metadata : fs_metadata_hashtbl = Hashtbl.create 10 - -(* running external commands/utility functions *) -exception SynchronousCommandError of Unix.process_status - -let run_sync command = - debug "Executing %s" command; - match Unix.system command with - | Unix.WEXITED(x) -> x - | x -> raise (SynchronousCommandError x) - -let run_checked_sync command = - match run_sync command with - | 0 -> () - | n -> raise (SynchronousCommandError (Unix.WEXITED n)) - -let unix_really_write oc s = Unix.write oc s 0 (String.length s) - -module FsTab = struct - type entry = { volume : string; - mntpoint : string; - fstype : string; - options : string list; - dump : int; pass : int } - - type t = entry list - - let new_fstab_entry volume mntpoint fstype options dump pass = - { volume=volume; mntpoint=mntpoint; fstype=fstype; - options=options; dump=dump; pass=pass } - - let entry_of_metadata volume metadata = - new_fstab_entry volume metadata.mounted_at "ext3" ["defaults"] 0 0 - - let entry_of_string line = - let line = String.strip String.isspace ( - if String.contains line '#' then - String.sub line 0 (String.index line '#') - else - line - ) in - let parts = String.split_f String.isspace line in - match parts with - | [ volume; mntpoint; fstype; options; dump; pass ] -> - let options = String.split ',' options in - let dump = int_of_string dump in - let pass = int_of_string pass in - new_fstab_entry volume mntpoint fstype options dump pass - | _ -> failwith ("malformed fstab entry "^line) - - let read filename = - let fd = open_in filename in - let rec _read () = - try - let line = input_line fd in - let line = String.strip String.isspace line in - if String.startswith "#" line then - _read () - else - (entry_of_string line)::(_read ()) - with - | End_of_file -> [] - in - finally _read (fun () -> close_in fd) - - let string_of_entry e = - let options = String.concat "," e.options in - Printf.sprintf "%s %s %s %s %d %d" e.volume e.mntpoint e.fstype options e.dump e.pass - - let is_local e = - String.startswith "/dev" e.volume || String.startswith "LABEL=" e.volume - - let filter fn es = List.filter fn es - - let update original updates = - let select e = - let selected = ref e in - List.iter (fun e2 -> if e2.mntpoint = e.mntpoint then selected := e2 else ()) updates; - !selected - in - let mapped = List.map select original in - - (* add new entries: *) - let exists l mntpoint = - List.fold_left (fun x e -> x || (e.mntpoint = mntpoint)) false l in - let new_entries = filter (fun x -> not (exists original x.mntpoint)) updates in - mapped @ new_entries -end - -(* XXX copied from xapi/helpers.ml: should move to util *) -let get_process_output ?(handler=(fun _ _ -> failwith "internal error")) cmd : string = - let inchan = Unix.open_process_in cmd in - - let buffer = Buffer.create 1024 - and buf = String.make 1024 '\000' in - - let rec read_until_eof () = - let rd = input inchan buf 0 1024 in - if rd = 0 then - () - else begin - Buffer.add_substring buffer buf 0 rd; - read_until_eof () - end - in - (* Make sure an exception doesn't prevent us from waiting for the child process *) - read_until_eof (); - match Unix.close_process_in inchan with - | Unix.WEXITED 0 -> Buffer.contents buffer - | x -> raise (SynchronousCommandError x) - -module RuntimeEnv = struct - exception AdminInterfaceError - exception ErrorFindingIP - exception ErrorFindingDefaultGateway - - let get_iface_ip iface = - let ifconfig = get_process_output ("/sbin/ifconfig " ^ iface) in - let lines = String.split '\n' ifconfig in - let ip_substr x = - let plain = String.strip String.isspace x in - let fst = String.index plain ':' + 1 in - let len = (String.index_from plain fst ' ') - fst in - String.sub plain fst len in - match List.filter (fun x ->String.has_substr x "inet addr:") lines with - | [ip] -> ip_substr ip - | _ -> raise ErrorFindingIP - - let get_gateway_ip () = (* router ip from xapi_udhcpd.write_config *) - let route = get_process_output ("/sbin/route") in - debug "output of /sbin/route: %s" route; - let lines = String.split '\n' route in - let ip_substr x = - let x = String.sub_to_end x (String.length "default") in - let plain = String.strip String.isspace x in - let fst = 0 in - let len = (String.index_from plain fst ' ') - fst in - String.sub plain fst len in - match List.filter (fun x ->String.has_substr x "default") lines with - | [ip] -> ip_substr ip - | _ -> raise ErrorFindingDefaultGateway - - let configure_networking () = - run_checked_sync "dhclient eth0"; - (* write our IP address to the guest-metrics field so that the client - knows how to connect to us. *) - let x = get_iface_ip "eth0" in - debug "got ip: %s; writing to guest-metrics" x; - let gw = get_gateway_ip () in - debug "got gateway to Dom0: %s; writing to guest-metrics" gw; - - let xs = Xs.domain_open () in - finally - (fun () -> (* signal p2v client via VM-guest-metrics.get_networks *) - (* guest-metrics needs the pv driver version numbers and data/updated key *) - xs.Xs.write "attr" ""; - xs.Xs.write "attr/PVAddons" ""; - xs.Xs.write "attr/PVAddons/MajorVersion" "5"; - xs.Xs.write "attr/PVAddons/MinorVersion" "5"; - xs.Xs.write "attr/PVAddons/MicroVersion" "8"; - (* reporting IP address to any VM-guest-metrics.get_networks callers *) - xs.Xs.write "attr/eth0" ""; - xs.Xs.write "attr/eth0/ip" gw; - xs.Xs.write "data/updated" "1"; - ) - (fun () -> Xs.close xs) -end - -module Compression = struct - type compression = Uncompressed | Gzip | Bzip2 - - let of_string = function - | "uncompressed" -> Uncompressed - | "gzip" -> Gzip - | "bzip2" -> Bzip2 - | _ -> failwith "Unknown compression type" - - let tar_parameter_of = function - | Uncompressed -> "" - | Gzip -> "z" - | Bzip2 -> "j" -end - -module Filesystem = struct - type filesystem = Ext3 | Swap - - let make volume fs fsopts = - let creation_tool = match fs with - | Ext3 -> "mkfs.ext3" - | Swap -> "mkswap" in - let device = Printf.sprintf "/dev/%s" volume in - let optstring = match fsopts with - | None -> "" - | Some x -> "-O "^x - in - run_checked_sync (Printf.sprintf "%s %s %s" creation_tool optstring device) - - let of_string = function - | "ext3" -> Ext3 - | "swap" -> Swap - | _ -> failwith "Unknown filesystem type" - - let string_of = function - | Ext3 -> "ext3" - | Swap -> "swap" -end - -(** wait for a file to appear. Useful for waiting on devices appearing in - /sys/block. *) -let rec wait_on_file fname = function - | 0 -> raise Not_found - | tries -> - if Sys.file_exists fname then - () - else begin - Unix.sleep 1; wait_on_file fname (tries - 1) - end - -let umount mntpoint = - run_checked_sync ("umount " ^ mntpoint) - -(* Mounting and unmounting devices: *) -type mount_action = { options : string list; - fstype : string option; - mntpoint : string option; - src : string } - -let new_mount_action ?options ?fstype ?mntpoint src = - let options = match options with - | None -> [] - | Some x -> x in - { options = options ; fstype = fstype ; mntpoint = mntpoint; - src = src } - -let mount action = - let mkname prefix = - (* make unique mountpoints *) - let i = ref 1 in - let _mkname x = prefix ^ "-" ^ (string_of_int x) in - let () = - while Sys.file_exists (_mkname !i) do - i := !i + 1 - done - in _mkname !i - in - let optionstring = - if action.options = [] then "" else "-o " ^ (String.concat "," action.options) in - let fstype_string = match action.fstype with - | None -> "" - | Some fstype -> "-t " ^ fstype in - let mntpoint = match action.mntpoint with - | None -> - let name = mkname "/tmp/withmnt" in - let () = assert_dir name 0o700 in - name - | Some x -> x - in - let mountcmd = - Printf.sprintf "mount %s %s %s %s" fstype_string optionstring action.src mntpoint in - debug "mount: about to execute %s" mountcmd; - ignore (run_checked_sync mountcmd); - mntpoint - -let with_mounted actions fn = - let rec _with_mounted actions mountpoints fn = - let cleanup x actual_mount () = - let mntpoint = unbox actual_mount.mntpoint in - umount mntpoint; - if x.mntpoint = None then Unix.rmdir mntpoint - in - match actions with - | [] -> - fn mountpoints - | x::xs -> - let actual_mount = { x with mntpoint = Some (mount x) } in - finally (fun () -> _with_mounted xs (actual_mount::mountpoints) fn) (cleanup x actual_mount) - in - _with_mounted actions [] fn - -let with_single_mount action fn = - let call a = - match a with - | [x] -> fn (unbox x.mntpoint) - | _ -> failwith "mount gave unexpected return value for with_single_mount" - in - with_mounted [ action ] call - -(** Get an argument from an association list, writing out appropriate HTTP - error codes, with a useful body, and raising an appropriate exception *) -let optional_arg query arg = - try - Some (List.assoc arg query) - with - Not_found -> None - -let select_arg bio query arg = - try - List.assoc arg query - with - Not_found as e -> begin - let s = Buf_io.fd_of bio in - Http.output_http s (Http.http_500_internal_error); - error "HTTP 500: An error occurred: a required parameter '%s' was not present in the RPC - aborting. This is likely a bug in your P2V client." arg; - let msg = Printf.sprintf "\r\nRequired parameter '%s' was not present.\r\n" arg in - ignore (unix_really_write s msg); - raise e - end - -let exn_to_http sock fn = - try fn () - with - | Api_errors.Server_error(code, params) as e -> begin - debug "exn_to_http: API Error:%s %s" (Api_errors.to_string e) (Printexc.to_string e); - Http.output_http sock Http.http_500_internal_error; - ignore (unix_really_write sock ("\r\nAPI Error: "^Api_errors.to_string e)) - end - | Failure e -> begin - debug "exn_to_http: Failure: %s" e; - Http.output_http sock Http.http_500_internal_error; - ignore (unix_really_write sock ("\r\nServer error: "^e)) - end - | exn -> begin - debug "exn_to_http: general: %s" (Printexc.to_string exn); - Http.output_http sock Http.http_500_internal_error; - end - - -let get_client_context_of_req req bio = - let session_id = Ref.of_string (select_arg bio req.Http.query "session_id") in - let host = (select_arg bio req.Http.query "host") in - let port = int_of_string (select_arg bio req.Http.query "port") in - let this_vm = Ref.of_string (select_arg bio req.Http.query "vm_id") in - let rpc xml = Xmlrpcclient.do_secure_xml_rpc ~host ~version:"1.1" ~port ~path:"/" xml in - (session_id,host,port,this_vm,rpc) - - -(** Create a disk with numbered ID exposed over HTTP: add to ID -> VBD map; - create a vbd for the vdi and attach the disk locally. *) -let make_disk volume sr size bootable session_id rpc this_vm = - let vmuuid = Client.VM.get_uuid ~rpc ~session_id ~self:this_vm in - let vdi = Client.VDI.create ~rpc ~session_id ~sR:sr - ~name_label:"Automatically created." ~name_description:"" - ~sharable:false ~read_only:false ~other_config:[] ~virtual_size:size - ~_type:`system ~sm_config:[ Xapi_globs._sm_vm_hint, vmuuid ] ~xenstore_data:[] ~tags:[] in - let vbd = Client.VBD.create ~rpc ~session_id ~vM:this_vm ~vDI:vdi - ~bootable ~mode:`RW ~_type:`Disk ~unpluggable:true ~qos_algorithm_type:"" - ~qos_algorithm_params:[] ~userdevice:volume ~empty:false - ~other_config:["owner", ""] in - - (* plug the disk in *) - Client.VBD.plug ~rpc ~session_id ~self:vbd; - try - let sys_path = "/dev/" ^ volume in - wait_on_file sys_path 10 - with - Not_found -> failwith "Device did not appear in /sys/block" - -(** HTTP callback for make-disk *) -let make_disk_callback req bio = - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - let volume = select_arg bio req.Http.query "volume" - and size = Int64.of_string (select_arg bio req.Http.query "size") - and bootable = select_arg bio req.Http.query "bootable" = "true" - and (session_id,host,port,this_vm,rpc) = get_client_context_of_req req bio - and sr_uuid = select_arg bio req.Http.query "sr" in - - let sr = Client.SR.get_by_uuid ~rpc ~session_id ~uuid:sr_uuid in - make_disk volume sr size bootable session_id rpc this_vm; - Http.output_http s (Http.http_200_ok ()) - ) - -(** Partition a disk according to a list of sizes. Only deals with - primary partitions. Assumes -1 means use rest of disk. Assumes - the disk has already been made with make_disk. *) -let partition_disk volume partition_sizes = - let device_node = Printf.sprintf "/dev/%s" volume in - let fd = Unix.open_process_out ("/sbin/fdisk " ^ device_node) in - - (* write partitions: *) - let count n = - let rec _count n m = if m <= n then m::(_count n (m + 1)) else [] in - _count n 1 - in - let mkpart part_num size = - let len = if size = -1 then "" else "+" ^ (string_of_int size) ^ "M" in - begin - output_string fd "n\n"; flush fd; (* new partition *) - output_string fd "p\n"; flush fd; (* primary *) - output_string fd ((string_of_int (part_num)) ^ "\n"); flush fd; (* number *) - output_string fd "\n"; flush fd; (* defualt start cyl *) - output_string fd (len ^ "\n"); flush fd (* size *) - end - in - List.iter2 mkpart (count (List.length partition_sizes)) partition_sizes; - - (* save changes *) - output_string fd "w\n"; flush fd; - - (* check exit code *) - let () = - match (Unix.close_process_out fd) with - | Unix.WEXITED(0) -> () - | _ -> failwith "Partitioning failed." - in () - -let partition_disk_callback req bio = - let rec shorten l = match l with - | [] -> [] - | None::_ -> [] - | (Some x)::xs -> x::(shorten xs) in - - let volume = select_arg bio req.Http.query "volume" - and parts = List.map int_of_string (shorten (List.map (optional_arg req.Http.query) [ "part1"; "part2"; "part3"; "part4" ])) in - - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - partition_disk volume parts; - Http.output_http s (Http.http_200_ok ()) - ) - -let mkfs_callback req bio = - let volume = select_arg bio req.Http.query "volume" - and fs = Filesystem.of_string (select_arg bio req.Http.query "fs") in - let fsopts = optional_arg req.Http.query "fsopts" in - - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - Filesystem.make volume fs fsopts; - Http.output_http s (Http.http_200_ok ()) - ) - -(** Unpack a tar-file from stdin to a volume *) -let unpack_tar volume compression data_iter (src:Http_svr.Chunked.t) = - let compression_string = Compression.tar_parameter_of compression in - let _unpack_tar mntpoint = - let tar = Unix.open_process_out (Printf.sprintf "tar -SC %s -x%sf -" mntpoint compression_string) in - finally (fun () -> data_iter (output_string tar) src) (fun () -> ignore (Unix.close_process_out tar)) in - with_single_mount (new_mount_action ("/dev/" ^ volume)) _unpack_tar - -let tar_callback req bio = - (* parse args *) - let volume = select_arg bio req.Http.query "volume" - and compression = Compression.of_string (select_arg bio req.Http.query "compression") in - - (* process incoming tarfile *) - let blksize = 1024 * 1024 in - let data_iter fn chunks = - let data = ref (Http_svr.Chunked.read chunks blksize) in - while !data <> "" do - fn !data; data := Http_svr.Chunked.read chunks blksize - done - in - let chunks = Http_svr.Chunked.of_bufio bio in - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - unpack_tar volume compression data_iter chunks; - Http.output_http s (Http.http_200_ok ()) - ) - -let print_callback req bio = - let chunks = Http_svr.Chunked.of_bufio bio in - let data = ref (Http_svr.Chunked.read chunks 1024) in - while !data <> "" do - Printf.printf "data: %s\n %!" !data; data := Http_svr.Chunked.read chunks 1024 - done; - let s = Buf_io.fd_of bio in - Http.output_http s (Http.http_200_ok ()) - -let set_fs_metadata volume md = - Hashtbl.replace fs_metadata volume md - -let set_fs_metadata_callback req bio = - let volume = select_arg bio req.Http.query "volume" in - let mntpoint = select_arg bio req.Http.query "mntpoint" in - - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - set_fs_metadata volume (new_fs_metadata mntpoint); - Http.output_http s (Http.http_200_ok ()) - ) - -(** Update fstab based on the metadata supplied via set_fs_metadata *) -let update_fstab root_vol = - let _update_fstab mntpoint = - (* work out new entries based on the filesystems we have received *) - let new_local = - let a = ref [] in - Hashtbl.iter (fun v m -> a := (FsTab.entry_of_metadata ("/dev/"^v) m)::!a) fs_metadata; - !a - in - (* fix up fstab: *) - let fstab_file = mntpoint ^ "/etc/fstab" in - let log_fstab prefix f = List.iter (fun e -> debug "%s: fstab - %s" prefix (FsTab.string_of_entry e)) f in - let fstab = FsTab.read fstab_file in - log_fstab "initial" fstab; let fstab = FsTab.filter (fun x -> not (FsTab.is_local x)) fstab in - log_fstab "filtered" fstab; let fstab = FsTab.update fstab new_local in - log_fstab "updated" fstab; - log_fstab "new local" new_local; - let fd = open_out fstab_file in - List.iter (fun e -> output_string fd ((FsTab.string_of_entry e)^"\n")) fstab; - close_out fd - in - with_single_mount (new_mount_action ("/dev/"^root_vol)) _update_fstab - -let update_fstab_callback req bio = - let root_vol = select_arg bio req.Http.query "root-vol" in - - let s = Buf_io.fd_of bio in - exn_to_http s (fun () -> - update_fstab root_vol; - Http.output_http s (Http.http_200_ok ()) - ) - -(** Get the guest on the PV road *) - -(* find the index of a substring *) -let strindex str searchstr = - let rec strindex str searchstr pos = - if str = "" then raise Not_found; - if String.startswith searchstr str then - pos - else - strindex (String.sub str 1 (String.length str - 1)) searchstr (pos + 1) - in strindex str searchstr 0 - -exception GrubConfigError - -let paravirtualise root_vol boot_merged session_id rpc this_vm = - (* set bootloader params -- assume grub for now: *) - Client.VM.set_PV_bootloader ~session_id ~rpc ~self:this_vm ~value:"pygrub"; - Client.VM.set_PV_kernel ~session_id ~rpc ~self:this_vm ~value:""; - Client.VM.set_PV_ramdisk ~session_id ~rpc ~self:this_vm ~value:""; - Client.VM.set_PV_args ~session_id ~rpc ~self:this_vm ~value:""; - - (* rewrite menu.lst or grub.conf so that it has the correct root= value - in all kernel lines; this makes grubby work when we install a new - kernel in the next stage. *) - let update_grub_conf mntpoint = - let grub_confs = [ "/boot/grub/menu.lst"; "/boot/grub/grub.conf" ] in - let grub_conf = - let rec select fn lst = - match lst with - | [] -> raise Not_found - | x::xs -> if (fn x) then x else (select fn xs) - in select (fun x -> Sys.file_exists (mntpoint ^ x)) grub_confs - in - - (* backup the file, then write out a new one: *) - debug "Backing up grub.conf..."; - let gdc = Unix.openfile (mntpoint ^ grub_conf) [ Unix.O_RDONLY ] 0o644 in - let gdc_bak = Unix.openfile (mntpoint ^ "/boot/grub/grub.conf.orig") [ Unix.O_RDWR; Unix.O_CREAT ] 0o644 in - finally (fun () -> ignore (copy_file gdc gdc_bak)) (fun () -> Unix.close gdc; Unix.close gdc_bak); - debug "Backup complete"; - - (* now write out a new one: here are the function to manipulate various - aspects of the command line - we apply each in turn to the input - lines to get a set of output lines: *) - let tweak_root parts = - let update_root s = if String.startswith "root=" s then ("root=/dev/"^root_vol) else s in - match parts with - | cmd::rest -> cmd::(List.map update_root rest) - | x -> x - in - let remove_console parts = - List.filter (fun part -> not (String.startswith "console=" part)) parts - in - let update_boot parts = - let insert_boot k = - (* /vmlinuz -> /boot/vmlinuz; (hd0,0)/vmlinuz -> (hd0,0)/boot/vmlinuz *) - let parts = String.split ~limit:2 '/' k in - match parts with - | [ disk; path ] -> (disk ^ "/boot/" ^ path) - | _ -> raise GrubConfigError - in - if boot_merged then begin - match parts with - | command::file::rest as x -> - if command = "kernel" || command = "module" || command = "initrd" then - command::(insert_boot file)::rest - else x - | x -> x - end else parts - in - - (* read in the existing file *) - let lines = - let gdc_bak = open_in (mntpoint ^ "/boot/grub/grub.conf.orig") in - finally (fun () -> - let lines = ref [] in - let () = try - while true do - lines := (input_line gdc_bak)::!lines - done - with End_of_file -> lines := List.rev !lines - in !lines - ) (fun () -> close_in gdc_bak) in - (* log what we read *) - List.iter (fun x -> debug "GRUB: %s" x) lines; - - (* split " xxx" into " ", "xxx" *) - let lstrip_save s = - let rec _lstrip_save s w = - let l = String.length s in - if l > 0 then begin - let first = String.get s 0 in - if String.isspace first then - _lstrip_save (String.sub s 1 (l - 1)) ((String.of_char first)^w) - else (w, s) - end else (w, s) - in - _lstrip_save s "" - in - - (* split " ", "x y z" into " ", ["x"; "y"; "z"] *) - let split_lines = - let split_command (w, str) = (w, String.split_f String.isspace str) in - List.map split_command (List.map lstrip_save lines) - in - - (* now apply the tweaks: *) - let tweak_line tweak_fun line = - let is_comment (w, parts) = - match parts with - | x::xs -> String.startswith "#" x - | _ -> false - in - if not (is_comment line) then - let (w, parts) = line in - (w, tweak_fun parts) - else - line - in - let new_lines = List.map (tweak_line tweak_root) split_lines in - let new_lines = List.map (tweak_line remove_console) new_lines in - let new_lines = List.map (tweak_line update_boot) new_lines in - let gdc = open_out (mntpoint ^ grub_conf) in - finally (fun () -> - let remerged_lines = List.map (fun (w, parts) -> - w^(String.concat " " parts) - ) new_lines in - List.iter (fun x -> debug "Update GRUB: %s" x) remerged_lines; - List.iter (fun x -> output_string gdc (x^"\n")) remerged_lines - ) (fun () -> close_out gdc) - in - with_single_mount (new_mount_action ("/dev/"^root_vol)) update_grub_conf; - - (* in-place P2V invocation: *) - let inplace_p2v mntpoint = - (* ensure /mnt exists in the target so we can mount the inplace-p2v - iso. *) - let iso_mount = mntpoint ^ "/mnt" in - let p2v_scripts_mount = mntpoint ^ "/mnt2" in - assert_dir iso_mount 0o766; - assert_dir p2v_scripts_mount 0o766; - - (* function to invoke the in-place P2V script. *) - let invoke actions = - (* in the chroot /mnt is the data disk, /mnt2 is a tmpfs waiting for the scripts, - since for some reason, bind mounts don't work from the rootfs here *) - ignore (Unix.system (Printf.sprintf "cp -a /opt/xensource/p2v/scripts/* %s/mnt2" mntpoint)); - ignore (Unix.system (Printf.sprintf "env EXTERNAL_P2V=Y chroot %s mnt2/xen-setup -b /mnt/Linux" mntpoint)); - List.iter (fun x -> - if Sys.file_exists (mntpoint^x) then Unix.unlink (mntpoint^x) - ) [ "/xenkernel"; "/xeninitrd"; "/boot/xenkernel"; "/boot/xeninitrd"] - in - (* make up a mounts list. We have to optionally omit /sys if the - directory doesn't exist in the target filesystem, e.g. on 2.4-based - kernel like RHEL 3. Mount a tmpfs on p2v_scripts_mount to copy the - P2V scripts into. This has to be done because for some reason bind - mounts from the rootfs here don't work...! *) - let mount_actions = [ - new_mount_action ~mntpoint:iso_mount "/dev/xvdp"; - new_mount_action ~mntpoint:p2v_scripts_mount ~fstype:"tmpfs" "scripts"; - new_mount_action ~mntpoint:(mntpoint^"/proc") ~fstype:"proc" "none"; - new_mount_action ~mntpoint:(mntpoint^"/dev") ~options:["bind"] "/dev"; - ] in - let mount_actions = - if Sys.file_exists ("mntpoint"^"/sys") then - (new_mount_action ~mntpoint:(mntpoint^"/sys") ~fstype:"sysfs" "none")::mount_actions - else - mount_actions - in - let () = with_mounted mount_actions invoke in () - in - let () = with_single_mount (new_mount_action ("/dev/"^root_vol)) inplace_p2v in () - -let paravirtualise_callback req bio = - let root_disk = select_arg bio req.Http.query "root-vol" - and (session_id,host,port,this_vm,rpc) = get_client_context_of_req req bio - and boot_merged = (select_arg bio req.Http.query "boot-merged") = "true" in - - let s = Buf_io.fd_of bio in - try - paravirtualise root_disk boot_merged session_id rpc this_vm; - Http.output_http s (Http.http_200_ok ()) - with - | Failure e -> begin - Http.output_http s Http.http_500_internal_error; - ignore (unix_really_write s ("\r\nServer error: "^e)) - end - | GrubConfigError -> begin - Http.output_http s Http.http_500_internal_error; - ignore (unix_really_write s "\r\nUnable to parse grub config. Please check and correct it, then try again.") - end - | exn -> begin - Http.output_http s Http.http_500_internal_error; - ignore (unix_really_write s "\r\nInternal server error.") - end - -let completed session_id rpc this_vm () = - (* remove xvdp, the P2V server ISO: *) - let vbds = Client.VM.get_VBDs ~rpc ~session_id ~self:this_vm in - let is_xvdp x = (Client.VBD.get_device ~rpc ~session_id ~self:x = "xvdp") in - let () = match List.filter is_xvdp vbds with - | xvdp::_ -> - Client.VBD.unplug ~rpc ~session_id ~self:xvdp; - Client.VBD.destroy ~rpc ~session_id ~self:xvdp - | [] -> () - in - (* halt *) - run_checked_sync "halt" - -let completed_callback req bio = - let s = Buf_io.fd_of bio - and (session_id,host,port,this_vm,rpc) = get_client_context_of_req req bio in - Http.output_http s (Http.http_200_ok ()); - (* close the socket ehre since we won't get to the normal cleanup code *) - Unix.close s; - completed session_id rpc this_vm () - -let _ = - Stunnel.init_stunnel_path (); - Logs.set "p2v" Log.Debug [ "stderr" ]; - Logs.set_default Log.Info [ "stderr" ]; - Logs.set_default Log.Warn [ "stderr" ]; - Logs.set_default Log.Error [ "stderr" ]; - - debug "hello"; - - RuntimeEnv.configure_networking (); - - Http_svr.add_handler Http.Get "/make-disk" (Http_svr.BufIO make_disk_callback); - Http_svr.add_handler Http.Get "/partition-disk" (Http_svr.BufIO partition_disk_callback); - Http_svr.add_handler Http.Get "/mkfs" (Http_svr.BufIO mkfs_callback); - Http_svr.add_handler Http.Put "/unpack-tar" (Http_svr.BufIO tar_callback); - Http_svr.add_handler Http.Get "/paravirtualise" (Http_svr.BufIO paravirtualise_callback); - Http_svr.add_handler Http.Get "/set-fs-metadata" (Http_svr.BufIO set_fs_metadata_callback); - Http_svr.add_handler Http.Get "/update-fstab" (Http_svr.BufIO update_fstab_callback); - Http_svr.add_handler Http.Get "/completed" (Http_svr.BufIO completed_callback); - Http_svr.add_handler Http.Put "/print" (Http_svr.BufIO print_callback); - - let inet_sock = Http_svr.bind listen_addr in - let (_ : Http_svr.server) = Http_svr.start (inet_sock, "inet_rpc") in - while (true) do Thread.delay 10000. done; diff -r b47a71895e80 -r 8a6800752019 ocaml/xapi/create_templates.ml --- a/ocaml/xapi/create_templates.ml Sun Jan 17 16:50:08 2010 +0000 +++ b/ocaml/xapi/create_templates.ml Sun Jan 17 18:23:36 2010 +0000 @@ -275,50 +275,6 @@ () end -(* The P2V server template *) -(* Requires: the xs-tools.iso in the XenSource Tools SR *) -let p2v_server_template rpc session_id = - (* Find the server ISO *) - match find_xs_tools_vdi rpc session_id with - | None -> - debug "Skipping P2V server template because the xs-tools.iso is missing" - | Some iso -> - begin match find_guest_installer_network rpc session_id with - | None -> - debug "Skipping P2V server template because guest installer network missing" - | Some net -> - let vm = find_or_create_template - { (blank_template (default_memory_parameters 256L)) with - vM_name_label = "XenSource P2V Server"; - vM_name_description = "An internal utility template for use by the XenSource P2V client"; - vM_other_config = [ Xapi_globs.grant_api_access, "internal"; - Xapi_globs.xensource_internal, "true"; - default_template - ] - } rpc session_id in - - let vbds = Client.VM.get_VBDs rpc session_id vm in - (* make a table of userdevice -> VBD reference, to check whether each VBD looks correct. *) - let table = List.map (fun vbd -> Client.VBD.get_userdevice rpc session_id vbd, vbd) vbds in - (* Empty CD on userdevice '3' *) - if not(List.mem_assoc "3" table) then begin - ignore (Client.VBD.create ~rpc ~session_id ~vM:vm ~empty:true ~vDI:(Ref.of_string "cd") ~userdevice:"3" ~bootable:false ~mode:`RO ~_type:`CD ~unpluggable:true ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~other_config:[]) - end; - (* Tools ISO on userdevice 'xvdp': it's either missing or pointing at the wrong VDI *) - let xvdp = "xvdp" in (* beware the deadly typo *) - if false - || not(List.mem_assoc xvdp table) - || (Client.VBD.get_VDI rpc session_id (List.assoc xvdp table) <> iso) then begin - (* destroy the existing broken one *) - if List.mem_assoc xvdp table then Client.VBD.destroy rpc session_id (List.assoc xvdp table); - ignore (Client.VBD.create ~rpc ~session_id ~vM:vm ~empty:false ~vDI:iso ~userdevice:xvdp ~bootable:true ~mode:`RO ~_type:`CD ~unpluggable:true ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~other_config:[]); - end; - - let vifs = Client.VM.get_VIFs rpc session_id vm in - if vifs = [] - then ignore (Client.VIF.create ~rpc ~session_id ~device:"0" ~mAC:(Record_util.random_mac_local ()) ~vM:vm ~mTU:1500L ~qos_algorithm_type:"" ~qos_algorithm_params:[] ~network:net ~other_config:[]) - end - (** Makes a Windows template using the given memory parameters in MiB, root disk size in GiB, and version string. *) let windows_template memory root_disk_size version = @@ -499,5 +455,4 @@ (* The remaining template-creation functions determine whether they have the necessary resources (ISOs, networks) or not: *) debian_xgt_template rpc session_id "Debian Etch 4.0" "Etch" "debian-etch.xgt" "debian-etch"; - p2v_server_template rpc session_id