1(* 2 * Copyright (C) 2006-2007 XenSource Ltd. 3 * Copyright (C) 2008 Citrix Ltd. 4 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com> 5 * 6 * This program is free software; you can redistribute it and/or modify 7 * it under the terms of the GNU Lesser General Public License as published 8 * by the Free Software Foundation; version 2.1 only. with the special 9 * exception on linking described in file LICENSE. 10 * 11 * This program is distributed in the hope that it will be useful, 12 * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 * GNU Lesser General Public License for more details. 15 *) 16 17type perms = Xsraw.perms 18type con = Xsraw.con 19type domid = int 20 21type xsh = 22{ 23 con: con; 24 debug: string list -> string; 25 directory: string -> string list; 26 read: string -> string; 27 readv: string -> string list -> string list; 28 write: string -> string -> unit; 29 writev: string -> (string * string) list -> unit; 30 mkdir: string -> unit; 31 rm: string -> unit; 32 getperms: string -> perms; 33 setperms: string -> perms -> unit; 34 setpermsv: string -> string list -> perms -> unit; 35 introduce: domid -> nativeint -> int -> unit; 36 release: domid -> unit; 37 resume: domid -> unit; 38 getdomainpath: domid -> string; 39 watch: string -> string -> unit; 40 unwatch: string -> string -> unit; 41} 42 43let get_operations con = { 44 con = con; 45 debug = (fun commands -> Xsraw.debug commands con); 46 directory = (fun path -> Xsraw.directory 0 path con); 47 read = (fun path -> Xsraw.read 0 path con); 48 readv = (fun dir vec -> Xsraw.readv 0 dir vec con); 49 write = (fun path value -> Xsraw.write 0 path value con); 50 writev = (fun dir vec -> Xsraw.writev 0 dir vec con); 51 mkdir = (fun path -> Xsraw.mkdir 0 path con); 52 rm = (fun path -> Xsraw.rm 0 path con); 53 getperms = (fun path -> Xsraw.getperms 0 path con); 54 setperms = (fun path perms -> Xsraw.setperms 0 path perms con); 55 setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); 56 introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); 57 release = (fun id -> Xsraw.release id con); 58 resume = (fun id -> Xsraw.resume id con); 59 getdomainpath = (fun id -> Xsraw.getdomainpath id con); 60 watch = (fun path data -> Xsraw.watch path data con); 61 unwatch = (fun path data -> Xsraw.unwatch path data con); 62} 63 64let transaction xsh = Xst.transaction xsh.con 65 66let has_watchevents xsh = Xsraw.has_watchevents xsh.con 67let get_watchevent xsh = Xsraw.get_watchevent xsh.con 68 69let read_watchevent xsh = Xsraw.read_watchevent xsh.con 70 71let make fd = get_operations (Xsraw.open_fd fd) 72let get_fd xsh = Xenbus.Xb.get_fd xsh.con.Xsraw.xb 73 74exception Timeout 75 76(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *) 77exception Timeout_with_nonempty_queue 78 79(* Just in case we screw up: poll the callback every couple of seconds rather 80 than wait for the whole timeout period *) 81let max_blocking_time = 5. (* seconds *) 82 83let read_watchevent_timeout xsh timeout callback = 84 let start_time = Unix.gettimeofday () in 85 let end_time = start_time +. timeout in 86 87 let left = ref timeout in 88 89 (* Returns true if a watch event in the queue satisfied us *) 90 let process_queued_events () = 91 let success = ref false in 92 while Xsraw.has_watchevents xsh.con && not(!success) 93 do 94 success := callback (Xsraw.get_watchevent xsh.con) 95 done; 96 !success in 97 (* Returns true if a watch event read from the socket satisfied us *) 98 let process_incoming_event () = 99 let fd = get_fd xsh in 100 let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in 101 102 (* If data is available for reading then read it *) 103 if r = [] 104 then false (* timeout, either a max_blocking_time or global *) 105 else callback (Xsraw.read_watchevent xsh.con) in 106 107 let success = ref false in 108 while !left > 0. && not(!success) 109 do 110 (* NB the 'callback' might call back into Xs functions 111 and as a side-effect, watches might be queued. Hence 112 we must process the queue on every loop iteration *) 113 114 (* First process all queued watch events *) 115 if not(!success) 116 then success := process_queued_events (); 117 (* Then block for one more watch event *) 118 if not(!success) 119 then success := process_incoming_event (); 120 (* Just in case our callback caused events to be queued 121 and this is our last time round the loop: this prevents 122 us throwing the Timeout_with_nonempty_queue spuriously *) 123 if not(!success) 124 then success := process_queued_events (); 125 126 (* Update the time left *) 127 let current_time = Unix.gettimeofday () in 128 left := end_time -. current_time 129 done; 130 if not(!success) then begin 131 (* Sanity check: it should be impossible for any 132 events to be queued here *) 133 if Xsraw.has_watchevents xsh.con 134 then raise Timeout_with_nonempty_queue 135 else raise Timeout 136 end 137 138 139let monitor_paths xsh l time callback = 140 let unwatch () = 141 List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in 142 List.iter (fun (w,v) -> xsh.watch w v) l; 143 begin try 144 read_watchevent_timeout xsh time callback; 145 with 146 exn -> unwatch (); raise exn; 147 end; 148 unwatch () 149 150let daemon_socket = Paths.xen_run_stored ^ "/socket" 151 152(** Throws this rather than a miscellaneous Unix.connect failed *) 153exception Failed_to_connect 154 155let daemon_open () = 156 try 157 let sockaddr = Unix.ADDR_UNIX(daemon_socket) in 158 let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in 159 Unix.connect sock sockaddr; 160 Unix.set_close_on_exec sock; 161 make sock 162 with _ -> raise Failed_to_connect 163 164let domain_open () = 165 let path = try 166 let devpath = "/dev/xen/xenbus" in 167 Unix.access devpath [ Unix.F_OK ]; 168 devpath 169 with Unix.Unix_error(_, _, _) -> 170 "/proc/xen/xenbus" in 171 172 let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in 173 Unix.set_close_on_exec fd; 174 make fd 175 176let close xsh = Xsraw.close xsh.con 177