CLEARWATER:CI-44

ocaml/events/event_listen.ml

@@ -41,7 +41,7 @@ let _ =
   Printf.printf "Connecting to Host: %s; Port: %d; Username: %s" !host !port !username;
 
   (* Interesting event stuff starts here: *)
-  let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2" in
+  let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2"  ~originator:"event_listen"  in
   Client.Event.register ~rpc ~session_id ~classes:["*"];
   while true do
     let events = events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in

ocaml/graph/graph.ml

@@ -142,7 +142,7 @@ let _ =
     "Display an object graph";
 
   (* Interesting event stuff starts here: *)
-  let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2" in
+  let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2" ~originator:"graph" in
   let classes = List.filter (fun x -> List.mem x Datamodel.expose_get_all_messages_for) all_classes in
   List.iter (fun x -> if not(List.mem x classes) then failwith (Printf.sprintf "Class %s not available" x)) !wanted;
 

ocaml/idl/datamodel.ml

@@ -1188,7 +1188,9 @@ let session_login  = call ~flags:[]
   ~versioned_params:
   [{param_type=String; param_name="uname"; param_doc="Username for login."; param_release=rio_release; param_default=None};
    {param_type=String; param_name="pwd"; param_doc="Password for login."; param_release=rio_release; param_default=None};
-   {param_type=String; param_name="version"; param_doc="Client API version."; param_release=miami_release; param_default=Some (VString "1.1")}]
+   {param_type=String; param_name="version"; param_doc="Client API version."; param_release=miami_release; param_default=Some (VString "1.1")};
+   {param_type=String; param_name="originator"; param_doc="Key string for distinguishing different API users sharing the same login name."; param_release=clearwater_release; param_default=Some (VString "")}
+  ]
   ~errs:[Api_errors.session_authentication_failed]
   ~secret:true
   ~allowed_roles:_R_ALL (*any static role can try to create a user session*)
@@ -3346,6 +3348,7 @@ let session =
 		  field ~in_product_since:rel_midnight_ride ~qualifier:StaticRO ~default_value:(Some(VSet [])) ~ty:(Set(String)) "rbac_permissions" "list with all RBAC permissions for this session";
 		  field ~in_product_since:rel_midnight_ride ~qualifier:DynamicRO ~ty:(Set(Ref _task)) "tasks" "list of tasks created using the current session";
 		  field ~in_product_since:rel_midnight_ride ~qualifier:StaticRO ~default_value:(Some (VRef (Ref.string_of Ref.null))) ~ty:(Ref _session) "parent" "references the parent session that created this session"; 
+		  field ~in_product_since:rel_clearwater ~qualifier:DynamicRO ~default_value:(Some(VString(""))) ~ty:String  "originator" "a key string provided by a API user to distinguish itself from other users sharing the same login name";
 		]
 	()
 

ocaml/idl/ocaml_backend/rbac_audit.ml

@@ -538,27 +538,32 @@ let denied ~__context ~session_id ~action ~permission ?args () =
 			audit_line_of __context session_id "DENIED" "" "" action permission ?args ()
 	)
 
-let session_destroy ~__context ~session_id =
-(*	
-	(* this is currently only creating spam in the audit log *)
-	let action="session.destroy" in
-	allowed_ok ~__context ~session_id ~action ~permission:action ()
-*)
-	()
-
-let session_create ~__context ~session_id ~uname =
+let session_create_or_destroy ~create ~__context ~session_id ~uname =
   wrap (fun () ->
 	let session_rec = DB_Action.Session.get_record ~__context ~self:session_id in
 	let s_is_intrapool = session_rec.API.session_pool in
 	let s_is_lsu = session_rec.API.session_is_local_superuser in
 	(* filters out intra-pool logins to avoid spamming the audit log *)
 	if (not s_is_intrapool) && (not s_is_lsu) then (
-		let action="session.create" in
+		let action = (if create then "session.create" else "session.destroy") in
+		let originator = session_rec.API.session_originator in
 		let sexpr_of_args = 
-			(get_sexpr_arg "uname" (match uname with None->""|Some u->u) "" "")::
+			(get_sexpr_arg "originator" originator "" "")::
 			[]
 		in
+		let sexpr_of_args =
+			if create then
+				(get_sexpr_arg "uname" (match uname with None->""|Some u->u) "" "")::
+				sexpr_of_args
+			else
+				sexpr_of_args
+		in
 		allowed_post_fn_ok ~__context ~session_id ~action ~sexpr_of_args ~permission:action ()
 	)
 	)
 
+let session_destroy ~__context ~session_id =
+	session_create_or_destroy ~uname:None ~create:false ~__context ~session_id
+
+let session_create ~__context ~session_id ~uname =
+	session_create_or_destroy ~create:true ~__context ~session_id ~uname

ocaml/idl/xenenterpriseapi-coversheet.tex

@@ -17,9 +17,9 @@
 \newcommand{\releasestatement}{}
 
 %% Document revision
-\newcommand{\revstring}{API Revision 1.10}
+\newcommand{\revstring}{API Revision 2.0}
 
 %% Document authors
 \newcommand{\docauthors}{
 }
-\newcommand{\legalnotice}{Copyright \copyright{} 2006-2012 Citrix Systems, Inc. All Rights Reserved.}
+\newcommand{\legalnotice}{Copyright \copyright{} 2006-2013 Citrix Systems, Inc. All Rights Reserved.}

ocaml/lvhdrt/lvhdrt.ml

@@ -39,7 +39,7 @@ let _ =
 
   (* Get a session *)
   let rpc = rpc_of_hostname !hostname in
-  let session = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.4" in
+  let session = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.4" ~originator:"lvhdrt" in
 
   try
     begin

ocaml/lvhdrt/utils.ml

@@ -334,7 +334,7 @@ let create_vdi_tree rpc session sr name_label size ?resize ?(pattern_type=1) pat
 
 
 let wait_for_fist rpc session sr ?(delay=90.0) fist =
-  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" in
+  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" "lvhdrt" in
 
   Client.Event.register rpc session2 ["sr"];
 
@@ -373,7 +373,7 @@ let wait_for_fist rpc session sr ?(delay=90.0) fist =
  * delay will be used if at least one VDI is not deleted (e.g. because it didn't
  * exist. *)
 let wait_for_vdi_deletion rpc session sr ?(delay=90.0) vdis =
-  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" in
+  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" "lvhdrt" in
 
   Client.Event.register rpc session2 ["vdi"];
   debug "Registered for vdi events";

ocaml/mpathalert/mpathalert.ml

@@ -67,7 +67,7 @@ let to_string alert =
 let rec retry_with_session f rpc x =
 	let session =
 		let rec aux () = 
-			try Client.Session.login_with_password ~rpc ~uname:"" ~pwd:"" ~version:"1.4"
+			try Client.Session.login_with_password ~rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:"mpathalert"
 			with _ -> Thread.delay !delay; aux () in
 		aux () in
 	try

ocaml/multipathrt/alert_utils.ml

@@ -104,7 +104,7 @@ let check_path_counts entry max_paths current_paths =
 
 (* For all messages m matching the check_message predicate, execute f m *)
 let wait_for_alert rpc session ?(delay=180.0) check_message f =
-  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" in
+  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" "multipathrt"in
   Client.Event.register rpc session2 ["message"];
 
   let finished = ref false in

ocaml/multipathrt/iscsi_utils.ml

@@ -160,7 +160,7 @@ let setup_iscsi_sr rpc session host iscsi_vm =
       (scsiid, sr)
 
 let wait_for_vm_to_run rpc session ?(delay=60.0) vm =
-  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" in
+  let session2 = Client.Session.login_with_password rpc !Globs.username !Globs.password "1.4" "multipathrt" in
   Client.Event.register rpc session2 ["vm"];
 
   let finished = ref false in

ocaml/multipathrt/multipathrt.ml

@@ -37,7 +37,7 @@ let _ =
 
   (* Get a session *)
   let rpc = rpc_of_hostname !hostname in
-  let session = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.4" in
+  let session = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.4" ~originator:"multipathrt" in
   try
     begin
       match !tc with

ocaml/network/network_monitor_thread.ml

@@ -34,7 +34,7 @@ let send_bond_change_alert dev interfaces message =
 	let ifaces = String.concat "+" (List.sort String.compare interfaces) in
 	let module XenAPI = Client.Client in
 	let session_id = XenAPI.Session.login_with_password
-		~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" in
+		~rpc:xapi_rpc ~uname:"" ~pwd:"" ~version:"1.4" ~originator:"networkd" in
 	Pervasiveext.finally
 		(fun _ ->
 			let obj_uuid = Util_inventory.lookup Util_inventory._installation_uuid in

ocaml/perftest/apiperf.ml

@@ -153,7 +153,7 @@ let _ =
 
   if not !master && !slave_limit = 0 then failwith "Must provide either -master or -slaves argument";
 
-  let session = Client.Session.login_with_password rpc "root" "xenroot" "1.2" in
+  let session = Client.Session.login_with_password rpc "root" "xenroot" "1.2" "perftest" in
   finally
     (fun () ->
        let hosts = Client.Host.get_all rpc session in

ocaml/perftest/createpool.ml

@@ -248,7 +248,7 @@ let create_sdk_pool session_id sdkname pool_name key ipbase =
 			if firstboot.(i) then true else begin
 				let rpc = remoterpc ip in
 				try
-					let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in    
+					let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" "perftest" in
 					finally
 						(fun () ->
 							let host = List.hd (Client.Host.get_all rpc s) in (* only one host because it hasn't joined the pool yet *)
@@ -282,7 +282,7 @@ let create_sdk_pool session_id sdkname pool_name key ipbase =
 	let host_uuids = Array.mapi (fun i vm -> 
 		let n = i + 1 in
 		let rpc = remoterpc (Printf.sprintf "192.168.%d.%d" pool.ipbase n) in
-		let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" in
+		let s = Client.Session.login_with_password rpc "root" "xensource" "1.1" "perftest" in
 		let h = List.hd (Client.Host.get_all rpc s) in
 		let u = Client.Host.get_uuid rpc s h in
 		debug "Setting name of host %d" n;
@@ -295,7 +295,7 @@ let create_sdk_pool session_id sdkname pool_name key ipbase =
 	) hosts in
 
 	let poolrpc = remoterpc (Printf.sprintf "192.168.%d.1" pool.ipbase) in
-	let poolses = Client.Session.login_with_password poolrpc "root" "xensource" "1.1" in
+	let poolses = Client.Session.login_with_password poolrpc "root" "xensource" "1.1" "perftest" in
 
 	let vpool=List.hd (Client.Pool.get_all poolrpc poolses) in
 	Client.Pool.add_to_other_config poolrpc poolses vpool "scenario" pool_name;

ocaml/perftest/perftest.ml

@@ -95,7 +95,7 @@ let _ =
 	List.iter (fun x -> debug "* %s" x) lines
     | _ ->
 
-	let session = Client.Session.login_with_password rpc "root" "xenroot" "1.2" in
+	let session = Client.Session.login_with_password rpc "root" "xenroot" "1.2" "perftest" in
 	let (_: API.string_to_string_map) = get_metadata rpc session in
 	finally
 	  (fun () ->
@@ -111,7 +111,7 @@ let _ =
 		 debug ~out:stderr "Not yet implemented ... ";
 	     | "run" ->
 		 let newrpc = if pool.Scenario.sdk then remoterpc (Printf.sprintf "192.168.%d.1" !ipbase) else rpc in
-		 let session = if pool.Scenario.sdk then Client.Session.login_with_password newrpc "root" "xensource" "1.2" else session in
+		 let session = if pool.Scenario.sdk then Client.Session.login_with_password newrpc "root" "xensource" "1.2" "perftest" else session in
 		 finally
 		   (fun () -> marshall pool (get_metadata newrpc session) (Tests.run newrpc session !key !run_all !iter))
 		   (fun () -> if pool.Scenario.sdk then Client.Session.logout newrpc session)

ocaml/sm-cli/test.ml

@@ -342,10 +342,10 @@ let _ =
 	rxtransport := (TCP (!host2, 80));
 	rtransport := (TCP (!host2, 80));
 
-	let localsession = XapiClient.Session.login_with_password xrpc !username !password "1.0" in
+	let localsession = XapiClient.Session.login_with_password xrpc !username !password "1.0" "sm-cli" in
 	session := Ref.string_of localsession;
 
-	let remotesession = XapiClient.Session.login_with_password rxrpc !username !password "1.0" in
+	let remotesession = XapiClient.Session.login_with_password rxrpc !username !password "1.0" "sm-cli" in
 	rsession := Ref.string_of remotesession;
 
 	let url = Printf.sprintf "http://%s/services/SM?session_id=%s" !host !session in

ocaml/toplevel/toplevelhelper.ml

@@ -24,4 +24,4 @@ let rpc xml =
 open Client
 
 let init_session username password =
-  Client.Session.login_with_password ~rpc ~uname:username ~pwd:password ~version:"1.2"
+  Client.Session.login_with_password ~rpc ~uname:username ~pwd:password ~version:"1.2" ~originator:"toplevel"

ocaml/vncproxy/vncproxy.ml

@@ -73,7 +73,7 @@ let _ =
     with _ ->
       List.hd (Client.VM.get_by_name_label rpc session_id vm) in
 
-  let session_id = Client.Session.login_with_password rpc !username !password "1.1" in
+  let session_id = Client.Session.login_with_password rpc !username !password "1.1" "vncproxy" in
   finally
     (fun () ->
        let vm = find_vm rpc session_id !vm in

ocaml/xapi/cancel_tests.ml

@@ -402,7 +402,7 @@ let _ =
     "Test VM lifecycle cancellation leaves the system in a valid state";
 
 	let rpc = make_rpc () in
-	let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2" in
+	let session_id = Client.Session.login_with_password ~rpc ~uname:!username ~pwd:!password ~version:"1.2" ~originator:"cancel_tests" in
 	finally
 		(fun () ->
 			match Client.VM.get_by_name_label ~rpc ~session_id ~label:!vm with

ocaml/xapi/cli_operations.ml

@@ -2490,7 +2490,7 @@ let vm_migrate printer rpc session_id params =
 				XML_protocol.rpc ~srcstr:"cli" ~dststr:"dst_xapi" ~transport:(SSL(SSL.make ~use_fork_exec_helper:false (), ip, 443)) ~http xml in
 			let username = List.assoc "remote-username" params in
 			let password = List.assoc "remote-password" params in
-			let remote_session = Client.Session.login_with_password remote_rpc username password "1.3" in
+			let remote_session = Client.Session.login_with_password remote_rpc username password "1.3" "" in
 			finally
 				(fun () ->
 					let host, host_record =

ocaml/xapi/create_storage_main.ml

@@ -31,6 +31,6 @@ let _ =
   let http = xmlrpc ~version:"1.0" "/" in
   let rpc xml = XML_protocol.rpc ~transport:(TCP(!host, !port)) ~http xml in
   let session_id = Client.Session.login_with_password ~rpc 
-    ~uname:!username ~pwd:!password ~version:Xapi_globs.api_version_string in
+    ~uname:!username ~pwd:!password ~version:Xapi_globs.api_version_string ~originator:"" in
   create_storage_localhost rpc session_id;
   Client.Session.logout ~rpc ~session_id

ocaml/xapi/db_gc.ml

@@ -221,7 +221,7 @@ let check_host_liveness ~__context =
 let task_status_is_completed task_status =
     (task_status=`success) || (task_status=`failure) || (task_status=`cancelled)
 
-let timeout_sessions_common ~__context sessions =
+let timeout_sessions_common ~__context sessions limit session_group =
   let unused_sessions = List.filter
     (fun (x, _) -> 
 	  let rec is_session_unused s = 
@@ -243,19 +243,18 @@ let timeout_sessions_common ~__context sessions =
     )
     sessions
   in
-  let disposable_sessions = unused_sessions in
   (* Only keep a list of (ref, last_active, uuid) *)
-  let disposable_sessions = List.map (fun (x, y) -> x, Date.to_float y.Db_actions.session_last_active, y.Db_actions.session_uuid) disposable_sessions in
+  let disposable_sessions = List.map (fun (x, y) -> x, Date.to_float y.Db_actions.session_last_active, y.Db_actions.session_uuid) unused_sessions in
   (* Definitely invalidate sessions last used long ago *)
   let threshold_time = Unix.time () -. !Xapi_globs.inactive_session_timeout in
   let young, old = List.partition (fun (_, y, _) -> y > threshold_time) disposable_sessions in
   (* If there are too many young sessions then we need to delete the oldest *)
   let lucky, unlucky = 
-    if List.length young <= Xapi_globs.max_sessions
+    if List.length young <= limit
     then young, [] (* keep them all *)
     else 
       (* Need to reverse sort by last active and drop the oldest *)
-      List.chop Xapi_globs.max_sessions (List.sort (fun (_,a, _) (_,b, _) -> compare b a) young) in
+      List.chop limit (List.sort (fun (_,a, _) (_,b, _) -> compare b a) young) in
   let cancel doc sessions = 
     List.iter
       (fun (s, active, uuid) ->
@@ -264,19 +263,31 @@ let timeout_sessions_common ~__context sessions =
 	 ) sessions in
   (* Only the 'lucky' survive: the 'old' and 'unlucky' are destroyed *)
   if unlucky <> [] 
-  then debug "Number of disposable sessions in database (%d/%d) exceeds limit (%d): will delete the oldest" (List.length disposable_sessions) (List.length sessions) Xapi_globs.max_sessions;
+  then debug "Number of disposable sessions in database (%d/%d) exceeds limit (%d): will delete the oldest" (List.length disposable_sessions) (List.length sessions) limit;
   cancel "Timed out session because of its age" old;
   cancel "Timed out session because max number of sessions was exceeded" unlucky
 
 let timeout_sessions ~__context =
-  let all_sessions =
-    Db.Session.get_internal_records_where ~__context ~expr:Db_filter_types.True
-  in
-  let (intrapool_sessions, normal_sessions) =
-    List.partition (fun (_, y) -> y.Db_actions.session_pool) all_sessions
-  in begin
-    timeout_sessions_common ~__context normal_sessions;
-    timeout_sessions_common ~__context intrapool_sessions;
+	let all_sessions = Db.Session.get_internal_records_where ~__context ~expr:Db_filter_types.True in
+	let pool_sessions, nonpool_sessions = List.partition (fun (_, s) -> s.Db_actions.session_pool) all_sessions in
+	let use_root_auth_name s = s.Db_actions.session_auth_user_name = "" || s.Db_actions.session_auth_user_name = "root" in
+	let anon_sessions, named_sessions = List.partition (fun (_, s) -> s.Db_actions.session_originator = "" && use_root_auth_name s) nonpool_sessions in
+	let session_groups = Hashtbl.create 37 in
+	List.iter (function (_, s) as rs ->
+		let key = if use_root_auth_name s then `Orig s.Db_actions.session_originator else `Name s.Db_actions.session_auth_user_name in
+		let current_sessions =
+			try Hashtbl.find session_groups key
+			with Not_found -> [] in
+		Hashtbl.replace session_groups key (rs :: current_sessions)
+	) named_sessions;
+	begin
+		Hashtbl.iter
+			(fun key ss -> match key with
+			| `Orig orig -> timeout_sessions_common ~__context ss Xapi_globs.max_sessions_per_originator ("originator:"^orig)
+			| `Name name -> timeout_sessions_common ~__context ss Xapi_globs.max_sessions_per_user_name ("username:"^name))
+			session_groups;
+		timeout_sessions_common ~__context anon_sessions Xapi_globs.max_sessions "external";
+		timeout_sessions_common ~__context pool_sessions Xapi_globs.max_sessions "internal";
   end
 
 let probation_pending_tasks = Hashtbl.create 53
@@ -470,8 +481,8 @@ let single_pass () =
 						"PGPUs", gc_PGPUs;
 						"Host patches", gc_Host_patches;
 						"Host CPUs", gc_host_cpus;
-						"Sessions", timeout_sessions;
 						"Tasks", timeout_tasks;
+						"Sessions", timeout_sessions;
 						"Messages", gc_messages;
 						(* timeout_alerts; *)
 						(* CA-29253: wake up all blocked clients *)

ocaml/xapi/quicktest_common.ml

@@ -156,7 +156,7 @@ let rpc = ref rpc_unix_domain
 let using_unix_domain_socket = ref true
 
 let init_session username password =
-  Client.Session.login_with_password ~rpc:!rpc ~uname:username ~pwd:password ~version:Xapi_globs.api_version_string
+  Client.Session.login_with_password ~rpc:!rpc ~uname:username ~pwd:password ~version:Xapi_globs.api_version_string ~originator:"quick_test"
 
 let get_pool session_id =
   let pool = Client.Pool.get_all !rpc session_id in

ocaml/xapi/xapi_cli.ml

@@ -68,7 +68,7 @@ let with_session ~local rpc u p session f =
   let session, logout = 
     match local, session with 
       | false, None -> 
-	  Client.Client.Session.login_with_password ~rpc ~uname:u ~pwd:p ~version:Xapi_globs.api_version_string, true
+	  Client.Client.Session.login_with_password ~rpc ~uname:u ~pwd:p ~version:Xapi_globs.api_version_string ~originator:"cli", true
       | true, None ->
 	  Client.Client.Session.slave_local_login_with_password ~rpc ~uname:u ~pwd:p, true
       | _, Some session -> session, false in