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>
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.
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.
20
let activate = ref true
22
type permty = READ | WRITE | RDWR | NONE
24
let char_of_permty perm =
31
let permty_of_char c =
37
| _ -> invalid_arg "unknown permission type"
40
(* node permissions *)
48
acl: (Xc.domid * permty) list;
51
let create owner other acl =
52
{ owner = owner; other = other; acl = acl }
54
let get_other perms = perms.other
55
let get_acl perms = perms.acl
56
let get_owner perm = perm.owner
58
let default0 = create 0 NONE []
60
let perm_of_string s =
61
let ty = permty_of_char s.[0]
62
and id = int_of_string (String.sub s 1 (String.length s - 1)) in
66
let vect = List.map (perm_of_string) ls in
68
| [] -> invalid_arg "permvec empty"
69
| h :: l -> create (fst h) (snd h) l
71
(* [s] must end with '\000' *)
73
let ls = String.split '\000' s in
74
let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
77
let string_of_perm perm =
78
Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
80
let to_string permvec =
81
let l = ((permvec.owner, permvec.other) :: permvec.acl) in
82
String.concat "\000" (List.map string_of_perm l)
87
(* permission of connections *)
91
type elt = Xc.domid * (permty list)
97
{ main = 0, [READ; WRITE];
100
let create ?(perms=[NONE]) domid : t =
101
{ main = (domid, perms);
104
let set_target (connection:t) ?(perms=[NONE]) domid =
105
{ connection with target = Some (domid, perms) }
107
let get_owners (connection:t) =
108
match connection.main, connection.target with
109
| c1, Some c2 -> [ fst c1; fst c2 ]
110
| c1, None -> [ fst c1 ]
112
let is_owner (connection:t) id =
113
match connection.target with
114
| Some target -> fst connection.main = id || fst target = id
115
| None -> fst connection.main = id
117
let is_dom0 (connection:t) =
118
is_owner connection 0
120
let restrict (connection:t) domid =
121
match connection.target, connection.main with
122
| None, (0, perms) -> { connection with main = (domid, perms) }
123
| _ -> raise Define.Permission_denied
125
let elt_to_string (i,p) =
126
Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p)))
128
let to_string connection =
129
Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target))
132
(* check if owner of the current connection and of the current node are the same *)
133
let check_owner (connection:Connection.t) (node:Node.t) =
134
if !activate && not (Connection.is_dom0 connection)
135
then Connection.is_owner connection (Node.get_owner node)
138
(* check if the current connection has the requested perm on the current node *)
139
let check (connection:Connection.t) request (node:Node.t) =
140
let check_acl domainid =
142
if List.mem_assoc domainid (Node.get_acl node)
143
then List.assoc domainid (Node.get_acl node)
144
else Node.get_other node
146
match perm, request with
148
Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
152
| WRITE, WRITE -> true
154
Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
157
Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
161
&& not (Connection.is_dom0 connection)
162
&& not (check_owner connection node)
163
&& not (List.exists check_acl (Connection.get_owners connection))
164
then raise Define.Permission_denied
166
let equiv perm1 perm2 =
167
(Node.to_string perm1) = (Node.to_string perm2)