(*
 * Copyright (C) 2006-2007 XenSource Ltd.
 * Copyright (C) 2008      Citrix Ltd.
 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
 *
 * 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.
 *)

open Xenbus

exception Partial_not_empty
exception Unexpected_packet of string

(** Thrown when a path looks invalid e.g. if it contains "//" *)
exception Invalid_path of string

let unexpected_packet expected received =
  let s = Printf.sprintf "expecting %s received %s"
      (Xb.Op.to_string expected)
      (Xb.Op.to_string received) in
  raise (Unexpected_packet s)

type con = {
  xb: Xenbus.Xb.t;
  watchevents: (string * string) Queue.t;
}

let close con =
  Xb.close con.xb

let capacity = { Xb.maxoutstanding = 1; maxwatchevents = 0; }

let open_fd fd = {
  xb = Xb.open_fd ~capacity fd;
  watchevents = Queue.create ();
}

let rec split_string ?limit:(limit=(-1)) c s =
  let i = try String.index s c with Not_found -> -1 in
  let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
  if i = -1 || nlimit = 0 then
    [ s ]
  else
    let a = String.sub s 0 i
    and b = String.sub s (i + 1) (String.length s - i - 1) in
    a :: (split_string ~limit: nlimit c b)

type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR

type perms = int * perm * (int * perm) list

let string_of_perms perms =
  let owner, other, acl = perms in
  let char_of_perm perm =
    match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
                  | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
  let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
  String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))

let perms_of_string s =
  let perm_of_char c =
    match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
                                  | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
                                  | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
  let perm_of_string s =
    if String.length s < 2
    then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s)
    else
      begin
        int_of_string (String.sub s 1 (String.length s - 1)),
        perm_of_char s.[0]
      end in
  let rec split s =
    try let i = String.index s '\000' in
      String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
    with Not_found -> if s = "" then [] else [ s ] in
  let l = List.map perm_of_string (split s) in
  match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])

(* send one packet - can sleep *)
let pkt_send con =
  if Xb.has_old_output con.xb then
    raise Partial_not_empty;
  let workdone = ref false in
  while not !workdone
  do
    workdone := Xb.output con.xb
  done

(* receive one packet - can sleep *)
let rec pkt_recv con =
  match Xb.input con.xb with
  | Some packet -> packet
  | None -> pkt_recv con

let pkt_recv_timeout con timeout =
  let fd = Xb.get_fd con.xb in
  let r, _, _ = Unix.select [ fd ] [] [] timeout in
  if r = [] then
    true, None
  else
    false, Xb.input con.xb

let queue_watchevent con data =
  let ls = split_string ~limit:2 '\000' data in
  if List.length ls != 2 then
    raise (Xb.Packet.DataError "arguments number mismatch");
  let event = List.nth ls 0
  and event_data = List.nth ls 1 in
  Queue.push (event, event_data) con.watchevents

let has_watchevents con = Queue.length con.watchevents > 0
let get_watchevent con = Queue.pop con.watchevents

let read_watchevent con =
  let pkt = pkt_recv con in
  match Xb.Packet.get_ty pkt with
  | Xb.Op.Watchevent ->
    queue_watchevent con (Xb.Packet.get_data pkt);
    Queue.pop con.watchevents
  | ty               -> unexpected_packet Xb.Op.Watchevent ty

(* send one packet in the queue, and wait for reply *)
let rec sync_recv ty con =
  let pkt = pkt_recv con in
  match Xb.Packet.get_ty pkt with
  | Xb.Op.Error       -> (
      match Xb.Packet.get_data pkt with
      | "ENOENT" -> raise Xb.Noent
      | "EAGAIN" -> raise Xb.Eagain
      | "EINVAL" -> raise Xb.Invalid
      | s        -> raise (Xb.Packet.Error s))
  | Xb.Op.Watchevent  ->
    queue_watchevent con (Xb.Packet.get_data pkt);
    sync_recv ty con
  | rty when rty = ty -> Xb.Packet.get_data pkt
  | rty               -> unexpected_packet ty rty

let sync f con =
  (* queue a query using function f *)
  f con.xb;
  if Xb.output_len con.xb = 0 then
    Printf.printf "output len = 0\n%!";
  let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
  pkt_send con;
  sync_recv ty con

let ack s =
  if s = "OK" then () else raise (Xb.Packet.DataError s)

(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *)
let validate_path path =
  (* Paths shouldn't have a "//" in the middle *)
  let bad = "//" in
  for offset = 0 to String.length path - (String.length bad) do
    if String.sub path offset (String.length bad) = bad then
      raise (Invalid_path path)
  done;
  (* Paths shouldn't have a "/" at the end, except for the root *)
  if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
    raise (Invalid_path path)

(** Check to see if a path is suitable for watches *)
let validate_watch_path path =
  (* Check for stuff like @releaseDomain etc first *)
  if path <> "" && path.[0] = '@' then ()
  else validate_path path

let debug command con =
  sync (Queueop.debug command) con

let directory tid path con =
  validate_path path;
  let data = sync (Queueop.directory tid path) con in
  split_string '\000' data

let read tid path con =
  validate_path path;
  sync (Queueop.read tid path) con

let readv tid dir vec con =
  List.map (fun path -> validate_path path; read tid path con)
    (if dir <> "" then
       (List.map (fun v -> dir ^ "/" ^ v) vec) else vec)

let getperms tid path con =
  validate_path path;
  perms_of_string (sync (Queueop.getperms tid path) con)

let watch path data con =
  validate_watch_path path;
  ack (sync (Queueop.watch path data) con)

let unwatch path data con =
  validate_watch_path path;
  ack (sync (Queueop.unwatch path data) con)

let transaction_start con =
  let data = sync (Queueop.transaction_start) con in
  try
    int_of_string data
  with
    _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))

let transaction_end tid commit con =
  try
    ack (sync (Queueop.transaction_end tid commit) con);
    true
  with
    Xb.Eagain -> false

let introduce domid mfn port con =
  ack (sync (Queueop.introduce domid mfn port) con)

let release domid con =
  ack (sync (Queueop.release domid) con)

let resume domid con =
  ack (sync (Queueop.resume domid) con)

let getdomainpath domid con =
  sync (Queueop.getdomainpath domid) con

let write tid path value con =
  validate_path path;
  ack (sync (Queueop.write tid path value) con)

let writev tid dir vec con =
  List.iter (fun (entry, value) ->
      let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
      validate_path path;
      write tid path value con) vec

let mkdir tid path con =
  validate_path path;
  ack (sync (Queueop.mkdir tid path) con)

let rm tid path con =
  validate_path path;
  try
    ack (sync (Queueop.rm tid path) con)
  with
    Xb.Noent -> ()

let setperms tid path perms con =
  validate_path path;
  ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)

let setpermsv tid dir vec perms con =
  List.iter (fun entry ->
      let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
      validate_path path;
      setperms tid path perms con) vec
