Source file perms.ml

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let info fmt = Logging.info "perms" fmt

exception Permission_denied

(* permission of connections *)
open Xs_protocol.ACL

type elt = domid * perm list
type t = { main : elt; target : elt option }

let superuser : t = { main = (0, [ READ; WRITE ]); target = None }
let of_domain domid : t = { main = (domid, [ READ; WRITE ]); target = None }

let set_target (connection : t) domid =
  { connection with target = Some (domid, [ READ; WRITE ]) }

let get_owners (connection : t) =
  match (connection.main, connection.target) with
  | c1, Some c2 -> [ fst c1; fst c2 ]
  | c1, None -> [ fst c1 ]

let is_owner (connection : t) id =
  match connection.target with
  | Some target -> fst connection.main = id || fst target = id
  | None -> fst connection.main = id

let is_dom0 (connection : t) = is_owner connection 0

let restrict (connection : t) domid =
  match (connection.target, connection.main) with
  | None, (0, perms) ->
      info "restricting connection from domid %d to domid %d" 0 domid;
      { connection with main = (domid, perms) }
  | _ -> raise Permission_denied

type permission =
  | READ
  | WRITE
  | CHANGE_ACL
  | DEBUG
  | INTRODUCE
  | ISINTRODUCED
  | RESUME
  | RELEASE
  | SET_TARGET
  | RESTRICT
  | CONFIGURE

let has (t : t) _p = if not (is_dom0 t) then raise Permission_denied

(* check if owner of the current connection and of the current node are the same *)
let check_owner (connection : t) (node : Xs_protocol.ACL.t) =
  if not (is_dom0 connection) then
    is_owner connection node.Xs_protocol.ACL.owner
  else true

(* check if the current connection has the requested perm on the current node *)
let check (connection : t) request (node : Xs_protocol.ACL.t) =
  let check_acl domainid =
    let perm =
      if List.mem_assoc domainid node.Xs_protocol.ACL.acl then
        List.assoc domainid node.Xs_protocol.ACL.acl
      else node.Xs_protocol.ACL.other
    in
    match (perm, request) with
    | Xs_protocol.ACL.NONE, _ ->
        info "Permission denied: Domain %d has no permission" domainid;
        false
    | Xs_protocol.ACL.RDWR, _ -> true
    | Xs_protocol.ACL.READ, READ -> true
    | Xs_protocol.ACL.WRITE, WRITE -> true
    | Xs_protocol.ACL.READ, _ ->
        info "Permission denied: Domain %d has read only access" domainid;
        false
    | Xs_protocol.ACL.WRITE, _ ->
        info "Permission denied: Domain %d has write only access" domainid;
        false
  in
  if
    true
    && (not (is_dom0 connection))
    && (not (check_owner connection node))
    && not (List.exists check_acl (get_owners connection))
  then raise Permission_denied