From f13fe5903361953e4ccf8602b9c8df7e64568d55 Mon Sep 17 00:00:00 2001

From: =?UTF-8?q?Edwin=20T=C3=B6r=C3=B6k?= <edvin.torok@citrix.com>

Date: Wed, 12 Oct 2022 19:13:02 +0100

Subject: tools/ocaml: Change Xb.input to return Packet.t option

MIME-Version: 1.0

Content-Type: text/plain; charset=UTF-8

Content-Transfer-Encoding: 8bit

The queue here would only ever hold at most one element.  This will simplify

follow-up patches.

This is part of XSA-326.

Reported-by: Julien Grall <jgrall@amazon.com>

Signed-off-by: Edwin Török <edvin.torok@citrix.com>

Acked-by: Christian Lindig <christian.lindig@citrix.com>

diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml

index 8404ddd8a682..165fd4a1edf4 100644

--- a/tools/ocaml/libs/xb/xb.ml

+++ b/tools/ocaml/libs/xb/xb.ml

@@ -45,7 +45,6 @@ type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * bytes

 type t =

 {

 	backend: backend;

-	pkt_in: Packet.t Queue.t;

 	pkt_out: Packet.t Queue.t;

 	mutable partial_in: partial_buf;

 	mutable partial_out: string;

@@ -62,7 +61,6 @@ let reconnect t = match t.backend with

 		Xs_ring.close backend.mmap;

 		backend.eventchn_notify ();

 		(* Clear our old connection state *)

-		Queue.clear t.pkt_in;

 		Queue.clear t.pkt_out;

 		t.partial_in <- init_partial_in ();

 		t.partial_out <- ""

@@ -124,7 +122,6 @@ let output con =

 (* NB: can throw Reconnect *)

 let input con =

-	let newpacket = ref false in

 	let to_read =

 		match con.partial_in with

 		| HaveHdr partial_pkt -> Partial.to_complete partial_pkt

@@ -143,21 +140,19 @@ let input con =

 		if Partial.to_complete partial_pkt = 0 then (

 			let pkt = Packet.of_partialpkt partial_pkt in

 			con.partial_in <- init_partial_in ();

-			Queue.push pkt con.pkt_in;

-			newpacket := true

-		)

+			Some pkt

+		) else None

 	| NoHdr (i, buf)      ->

 		(* we complete the partial header *)

 		if sz > 0 then

 			Bytes.blit b 0 buf (Partial.header_size () - i) sz;

 		con.partial_in <- if sz = i then

-			HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf)

-	);

-	!newpacket

+			HaveHdr (Partial.of_string (Bytes.to_string buf)) else NoHdr (i - sz, buf);

+		None

+	)

 let newcon backend = {

 	backend = backend;

-	pkt_in = Queue.create ();

 	pkt_out = Queue.create ();

 	partial_in = init_partial_in ();

 	partial_out = "";

@@ -193,9 +188,6 @@ let has_output con = has_new_output con || has_old_output con

 let peek_output con = Queue.peek con.pkt_out

-let input_len con = Queue.length con.pkt_in

-let has_in_packet con = Queue.length con.pkt_in > 0

-let get_in_packet con = Queue.pop con.pkt_in

 let has_partial_input con = match con.partial_in with

 	| HaveHdr _ -> true

 	| NoHdr (n, _) -> n < Partial.header_size ()

diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli

index 794e35bb343e..91c682162cea 100644

--- a/tools/ocaml/libs/xb/xb.mli

+++ b/tools/ocaml/libs/xb/xb.mli

@@ -77,7 +77,7 @@ val write_fd : backend_fd -> 'a -> string -> int -> int

 val write_mmap : backend_mmap -> 'a -> string -> int -> int

 val write : t -> string -> int -> int

 val output : t -> bool

-val input : t -> bool

+val input : t -> Packet.t option

 val newcon : backend -> t

 val open_fd : Unix.file_descr -> t

 val open_mmap : Xenmmap.mmap_interface -> (unit -> unit) -> t

@@ -89,10 +89,7 @@ val has_new_output : t -> bool

 val has_old_output : t -> bool

 val has_output : t -> bool

 val peek_output : t -> Packet.t

-val input_len : t -> int

-val has_in_packet : t -> bool

 val has_partial_input : t -> bool

-val get_in_packet : t -> Packet.t

 val has_more_input : t -> bool

 val is_selectable : t -> bool

 val get_fd : t -> Unix.file_descr

diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml

index d982fb24dbb1..451f8b38dbcc 100644

--- a/tools/ocaml/libs/xs/xsraw.ml

+++ b/tools/ocaml/libs/xs/xsraw.ml

@@ -94,26 +94,18 @@ let pkt_send con =

 	done

 (* receive one packet - can sleep *)

-let pkt_recv con =

-	let workdone = ref false in

-	while not !workdone

-	do

-		workdone := Xb.input con.xb

-	done;

-	Xb.get_in_packet con.xb

+let rec pkt_recv con =

+	match Xb.input con.xb with

+	| Some packet -> packet

+	| None -> pkt_recv con

 let pkt_recv_timeout con timeout =

 	let fd = Xb.get_fd con.xb in

 	let r, _, _ = Unix.select [ fd ] [] [] timeout in

 	if r = [] then

 		true, None

-	else (

-		let workdone = Xb.input con.xb in

-		if workdone then

-			false, (Some (Xb.get_in_packet con.xb))

-		else

-			false, None

-	)

+	else

+		false, Xb.input con.xb

 let queue_watchevent con data =

 	let ls = split_string ~limit:2 '\000' data in

diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml

index 38b47363a173..cc20e047d2b9 100644

--- a/tools/ocaml/xenstored/connection.ml

+++ b/tools/ocaml/xenstored/connection.ml

@@ -277,9 +277,7 @@ let get_transaction con tid =

 	Hashtbl.find con.transactions tid

 let do_input con = Xenbus.Xb.input con.xb

-let has_input con = Xenbus.Xb.has_in_packet con.xb

 let has_partial_input con = Xenbus.Xb.has_partial_input con.xb

-let pop_in con = Xenbus.Xb.get_in_packet con.xb

 let has_more_input con = Xenbus.Xb.has_more_input con.xb

 let has_output con = Xenbus.Xb.has_output con.xb

@@ -307,7 +305,7 @@ let is_bad con = match con.dom with None -> false | Some dom -> Domain.is_bad_do

    Restrictions below can be relaxed once xenstored learns to dump more

    of its live state in a safe way *)

 let has_extra_connection_data con =

-	let has_in = has_input con || has_partial_input con in

+	let has_in = has_partial_input con in

 	let has_out = has_output con in

 	let has_socket = con.dom = None in

 	let has_nondefault_perms = make_perm con.dom <> con.perm in

diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml

index 6a3435c265d3..2d67456a2aa0 100644

--- a/tools/ocaml/xenstored/process.ml

+++ b/tools/ocaml/xenstored/process.ml

@@ -195,10 +195,9 @@ let parse_live_update args =

 			| _ when Unix.gettimeofday () < t.deadline -> false

 			| l ->

 				warn "timeout reached: have to wait, migrate or shutdown %d domains:" (List.length l);

-				let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, in: %b, out: %b, perm: %s"

+				let msgs = List.rev_map (fun con -> Printf.sprintf "%s: %d tx, out: %b, perm: %s"

 					(Connection.get_domstr con)

 					(Connection.number_of_transactions con)

-					(Connection.has_input con)

 					(Connection.has_output con)

 					(Connection.get_perm con |> Perms.Connection.to_string)

 					) l in

@@ -705,16 +704,17 @@ let do_input store cons doms con =

 			info "%s requests a reconnect" (Connection.get_domstr con);

 			History.reconnect con;

 			info "%s reconnection complete" (Connection.get_domstr con);

-			false

+			None

 		| Failure exp ->

 			error "caught exception %s" exp;

 			error "got a bad client %s" (sprintf "%-8s" (Connection.get_domstr con));

 			Connection.mark_as_bad con;

-			false

+			None

 	in

-	if newpacket then (

-		let packet = Connection.pop_in con in

+	match newpacket with

+	| None -> ()

+	| Some packet ->

 		let tid, rid, ty, data = Xenbus.Xb.Packet.unpack packet in

 		let req = {Packet.tid=tid; Packet.rid=rid; Packet.ty=ty; Packet.data=data} in

@@ -724,8 +724,7 @@ let do_input store cons doms con =

 		         (Xenbus.Xb.Op.to_string ty) (sanitize_data data); *)

 		process_packet ~store ~cons ~doms ~con ~req;

 		write_access_log ~ty ~tid ~con:(Connection.get_domstr con) ~data;

-		Connection.incr_ops con;

-	)

+		Connection.incr_ops con

 let do_output _store _cons _doms con =

 	if Connection.has_output con then (