1(*
2 * Copyright (C) 2006-2007 XenSource Ltd.
3 * Copyright (C) 2008      Citrix Ltd.
4 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
5 * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
6 *
7 * This program is free software; you can redistribute it and/or modify
8 * it under the terms of the GNU Lesser General Public License as published
9 * by the Free Software Foundation; version 2.1 only. with the special
10 * exception on linking described in file LICENSE.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 * GNU Lesser General Public License for more details.
16 *)
17
18let info fmt = Logging.info "perms" fmt
19
20open Stdext
21
22let activate = ref true
23let watch_activate = ref true
24
25type permty = READ | WRITE | RDWR | NONE
26
27let char_of_permty perm =
28	match perm with
29	| READ -> 'r'
30	| WRITE -> 'w'
31	| RDWR -> 'b'
32	| NONE -> 'n'
33
34let permty_of_char c =
35	match c with
36	| 'r' -> READ
37	| 'w' -> WRITE
38	| 'b' -> RDWR
39	| 'n' -> NONE
40	| _ -> invalid_arg "unknown permission type"
41
42
43(* node permissions *)
44module Node =
45struct
46
47type t =
48{
49	owner: Xenctrl.domid;
50	other: permty;
51	acl: (Xenctrl.domid * permty) list;
52}
53
54let create owner other acl =
55	{ owner = owner; other = other; acl = acl }
56
57let get_other perms = perms.other
58let get_acl perms = perms.acl
59let get_owner perm = perm.owner
60
61(** [remote_domid ~domid perm] removes all ACLs for [domid] from perm.
62* If [domid] was the owner then it is changed to Dom0.
63* This is used for cleaning up after dead domains.
64* *)
65let remove_domid ~domid perm =
66	let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in
67	let owner = if perm.owner = domid then 0 else perm.owner in
68	{ perm with acl; owner }
69
70let default0 = create 0 NONE []
71
72let perm_of_string s =
73	let ty = permty_of_char s.[0]
74	and id = int_of_string (String.sub s 1 (String.length s - 1)) in
75	(id, ty)
76
77let of_strings ls =
78	let vect = List.map (perm_of_string) ls in
79	match vect with
80	| [] -> invalid_arg "permvec empty"
81	| h :: l -> create (fst h) (snd h) l
82
83(* [s] must end with '\000' *)
84let of_string s =
85	let ls = String.split '\000' s in
86	let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
87	of_strings ls
88
89let string_of_perm perm =
90	Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
91
92let to_string ?(sep="\000") permvec =
93	let l = ((permvec.owner, permvec.other) :: permvec.acl) in
94	String.concat sep (List.map string_of_perm l)
95
96end
97
98
99(* permission of connections *)
100module Connection =
101struct
102
103type elt = Xenctrl.domid * (permty list)
104type t =
105	{ main: elt;
106	  target: elt option; }
107
108let full_rights : t =
109	{ main = 0, [READ; WRITE];
110	  target = None }
111
112let create ?(perms=[NONE]) domid : t =
113	{ main = (domid, perms);
114	  target = None }
115
116let set_target (connection:t) ?(perms=[NONE]) domid =
117	{ connection with target = Some (domid, perms) }
118
119let get_owners (connection:t) =
120	match connection.main, connection.target with
121	| c1, Some c2 -> [ fst c1; fst c2 ]
122	| c1, None    -> [ fst c1 ]
123
124let is_owner (connection:t) id =
125	match connection.target with
126	| Some target -> fst connection.main = id || fst target = id
127	| None        -> fst connection.main = id
128
129let is_dom0 (connection:t) =
130	is_owner connection 0
131
132let elt_to_string (i,p) =
133	Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p)))
134
135let to_string connection =
136	Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target))
137end
138
139(* check if owner of the current connection and of the current node are the same *)
140let check_owner (connection:Connection.t) (node:Node.t) =
141	if !activate && not (Connection.is_dom0 connection)
142	then Connection.is_owner connection (Node.get_owner node)
143	else true
144
145(* check if the current connection lacks the requested perm on the current node *)
146let lacks (connection:Connection.t) request (node:Node.t) =
147	let check_acl domainid =
148		let perm =
149			if List.mem_assoc domainid (Node.get_acl node)
150			then List.assoc domainid (Node.get_acl node)
151			else Node.get_other node
152		in
153		match perm, request with
154		| NONE, _ ->
155			info "Permission denied: Domain %d has no permission" domainid;
156			false
157		| RDWR, _ -> true
158		| READ, READ -> true
159		| WRITE, WRITE -> true
160		| READ, _ ->
161			info "Permission denied: Domain %d has read only access" domainid;
162			false
163		| WRITE, _ ->
164			info "Permission denied: Domain %d has write only access" domainid;
165			false
166	in
167	!activate
168	&& not (Connection.is_dom0 connection)
169	&& not (check_owner connection node)
170	&& not (List.exists check_acl (Connection.get_owners connection))
171
172(* check if the current connection has the requested perm on the current node.
173*  Raises an exception if it doesn't. *)
174let check connection request node =
175	if lacks connection request node
176	then raise Define.Permission_denied
177
178(* check if the current connection has the requested perm on the current node *)
179let has connection request node = not (lacks connection request node)
180
181let can_fire_watch connection perms =
182	not !watch_activate
183	|| List.exists (has connection READ) perms
184
185let equiv perm1 perm2 =
186	(Node.to_string perm1) = (Node.to_string perm2)
187