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
47  type t =
48    {
49      owner: Xenctrl.domid;
50      other: permty;
51      acl: (Xenctrl.domid * permty) list;
52    }
53
54  let create owner other acl =
55    { owner = owner; other = other; acl = acl }
56
57  let get_other perms = perms.other
58  let get_acl perms = perms.acl
59  let 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   * *)
65  let remove_domid ~domid perm =
66    let acl = List.filter (fun (acl_domid, _) -> acl_domid <> domid) perm.acl in
67    if perm.owner = domid then None else Some { perm with acl; owner = perm.owner }
68
69  let default0 = create 0 NONE []
70
71  let perm_of_string s =
72    let ty = permty_of_char s.[0]
73    and id = Utils.int_of_string_exn (String.sub s 1 (String.length s - 1)) in
74    (id, ty)
75
76  let of_strings ls =
77    let vect = List.map (perm_of_string) ls in
78    match vect with
79    | [] -> invalid_arg "permvec empty"
80    | h :: l -> create (fst h) (snd h) l
81
82  (* [s] must end with '\000' *)
83  let of_string s =
84    let ls = String.split '\000' s in
85    let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
86    of_strings ls
87
88  let string_of_perm perm =
89    Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
90
91  let to_string ?(sep="\000") permvec =
92    let l = ((permvec.owner, permvec.other) :: permvec.acl) in
93    String.concat sep (List.map string_of_perm l)
94
95end
96
97
98(* permission of connections *)
99module Connection =
100struct
101
102  type elt = Xenctrl.domid * (permty list)
103  type t =
104    { main: elt;
105      target: elt option; }
106
107  let full_rights : t =
108    { main = 0, [READ; WRITE];
109      target = None }
110
111  let create ?(perms=[NONE]) domid : t =
112    { main = (domid, perms);
113      target = None }
114
115  let set_target (connection:t) ?(perms=[NONE]) domid =
116    { connection with target = Some (domid, perms) }
117
118  let get_owners (connection:t) =
119    match connection.main, connection.target with
120    | c1, Some c2 -> [ fst c1; fst c2 ]
121    | c1, None    -> [ fst c1 ]
122
123  let is_owner (connection:t) id =
124    match connection.target with
125    | Some target -> fst connection.main = id || fst target = id
126    | None        -> fst connection.main = id
127
128  let is_dom0 (connection:t) =
129    is_owner connection 0
130
131  let elt_to_string (i,p) =
132    Printf.sprintf "%i%S" i (String.concat "" (List.map String.of_char (List.map char_of_permty p)))
133
134  let to_string connection =
135    Printf.sprintf "%s%s" (elt_to_string connection.main) (default "" (may elt_to_string connection.target))
136end
137
138(* check if owner of the current connection and of the current node are the same *)
139let check_owner (connection:Connection.t) (node:Node.t) =
140  if !activate && not (Connection.is_dom0 connection)
141  then Connection.is_owner connection (Node.get_owner node)
142  else true
143
144(* check if the current connection lacks the requested perm on the current node *)
145let lacks (connection:Connection.t) request (node:Node.t) =
146  let check_acl domainid =
147    let perm =
148      if List.mem_assoc domainid (Node.get_acl node)
149      then List.assoc domainid (Node.get_acl node)
150      else Node.get_other node
151    in
152    match perm, request with
153    | NONE, _ ->
154      info "Permission denied: Domain %d has no permission" domainid;
155      false
156    | RDWR, _ -> true
157    | READ, READ -> true
158    | WRITE, WRITE -> true
159    | READ, _ ->
160      info "Permission denied: Domain %d has read only access" domainid;
161      false
162    | WRITE, _ ->
163      info "Permission denied: Domain %d has write only access" domainid;
164      false
165  in
166  !activate
167  && not (Connection.is_dom0 connection)
168  && not (check_owner connection node)
169  && not (List.exists check_acl (Connection.get_owners connection))
170
171(* check if the current connection has the requested perm on the current node.
172 *  Raises an exception if it doesn't. *)
173let check connection request node =
174  if lacks connection request node
175  then raise Define.Permission_denied
176
177(* check if the current connection has the requested perm on the current node *)
178let has connection request node = not (lacks connection request node)
179
180let can_fire_watch connection perms =
181  not !watch_activate
182  || List.exists (has connection READ) perms
183
184let equiv perm1 perm2 =
185  (Node.to_string perm1) = (Node.to_string perm2)
186