(* $Id: rpc_key_service.mlp 1201 2008-08-31 23:41:22Z gerd $
 * ----------------------------------------------------------------------
 *
 *)

exception Netname_unknown
exception No_secret_key
exception Key_service_problem of exn

let () =
  Netexn.register_printer
    (Key_service_problem Not_found)
    (fun e ->
       match e with
	 | Key_service_problem e' ->
	     "Rpc_key_service.Key_service_problem(" ^ Netexn.to_string e' ^ ")"
	 | _ ->
	     assert false
    )


module A = Rpc_key_aux
module C1 = Rpc_key_clnt.KEY_PROG.KEY_VERS
module C2 = Rpc_key_clnt.KEY_PROG.KEY_VERS2
module C = C2

let program = A.program_KEY_PROG'KEY_VERS2

type client =
    [ `Direct of Rpc_client.t
    | `Keyenvoy of string
    ]

type connector =
    [ `Direct of (Rpc_client.connector * Rpc.protocol)
    | `Keyenvoy of string                    (* path of keyenvoy program *)
    ]


type t =
    { mutable client : client;
      conn : connector;
    }

let unixdomain_connector =
  `Direct (Rpc_client.Unix "/var/run/keyservsock", Rpc.Tcp) ;;

let keyenvoy_connector =
  `Keyenvoy "/usr/etc/keyenvoy" ;;

let default_connector = @CONNECTOR@_connector ;;

  (* GLIBC 2.1, FreeBSD: /var/run/keyservsock
   * Older Linux, SunOS, and others: Fork and start "/usr/etc/keyenvoy"
   * (very slow)
   * Solaris: Use TLICOTS loopback transport as reported from rpcbind
   *)

let create ?(connector = default_connector) () =
  match connector with
      `Direct (conn,prot) ->
	let c = C.create_client conn prot in
	Rpc_client.set_auth_methods c [ Rpc_auth_sys.client_auth_method() ];
	{ client = `Direct c; conn = connector }
    | `Keyenvoy path ->
	{ client = `Keyenvoy path; conn = connector }
;;


let wrap_exn f arg =
  try
    f arg
  with
      err -> raise(Key_service_problem err)
;;


let with_reconnect keyserv f =
  try
    wrap_exn f keyserv.client
  with
      Key_service_problem Rpc_client.Client_is_down ->
	let keyserv' = create ~connector:keyserv.conn () in
	keyserv.client <- keyserv'.client;
	wrap_exn f keyserv.client
;;


let call_keyenvoy keyenvoy_path procname xdr_arg  =
  let (procnumber, type_arg, type_result) =
                                      Rpc_program.signature program procname in

  let packed_arg = Xdr.pack_xdr_value_as_string xdr_arg type_arg [] in
  let (f_in, f_out) = Unix.open_process keyenvoy_path in
  let buf = String.create 1080 in     (* maximum length *)
  let pos = ref 0 in
  try
    output_string f_out (Rtypes.uint4_as_string procnumber);
    output_string f_out packed_arg;
    close_out f_out;     (* It is not an error to close files several times *)
    while true do
      let n = input f_in buf !pos (String.length buf - !pos) in
      if n = 0 then raise End_of_file;
      pos := !pos + n
    done;
    assert false
  with
      End_of_file ->
	( match Unix.close_process(f_in, f_out) with
	      Unix.WEXITED 0 -> ()
	    | _ -> failwith "call_keyenvoy"
	);
	let packed_result = String.sub buf 0 !pos in
	let xdr_result = Xdr.unpack_xdr_value ~fast:true packed_result type_result [] in
	xdr_result
    | err ->
	(ignore (Unix.close_process(f_in, f_out)));
	raise err
;;


let generate keyserv =
  with_reconnect keyserv
    (fun client ->
       match client with
	   `Direct dclient -> C.key_gen dclient ()
	 | `Keyenvoy path ->
	     A._to_des_block (call_keyenvoy path "KEY_GEN" Xdr.XV_void)
    )
;;


let encrypt keyserv remotename data =
  with_reconnect keyserv
    (fun client ->
       let arg = { A.remotename = remotename; A.deskey = data } in
       let r =
	 match client with
	     `Direct dclient ->
	       C.key_encrypt dclient arg
	   | `Keyenvoy path ->
	       A._to_cryptkeyres (call_keyenvoy path "KEY_ENCRYPT"
				    (A._of_cryptkeyarg arg))
       in
       match r with
	   `key_success encdata -> encdata
	 | `key_nosecret -> raise No_secret_key
	 | `key_unknown -> raise Netname_unknown
	 | `key_systemerr -> failwith "Rpc_key_service.encrypt"
    )
;;


let decrypt keyserv remotename encdata =
  with_reconnect keyserv
    (fun client ->
       let arg = { A.remotename = remotename; A.deskey = encdata } in
       let r =
	 match client with
	     `Direct dclient ->
	       C.key_decrypt dclient arg
	   | `Keyenvoy path ->
	       A._to_cryptkeyres (call_keyenvoy path "KEY_DECRYPT"
				    (A._of_cryptkeyarg arg))
       in
       match r with
	   `key_success data -> data
	 | `key_nosecret -> raise No_secret_key
	 | `key_unknown -> raise Netname_unknown
	 | `key_systemerr -> failwith "Rpc_key_service.decrypt"
    )
;;


let net_get keyserv =
  with_reconnect keyserv
    (fun client ->
       let r =
	 match client with
	     `Direct dclient ->
	       C.key_net_get dclient ()
	   | `Keyenvoy path ->
	       A._to_key_netstres (call_keyenvoy path "KEY_NET_GET" Xdr.XV_void)
       in
       match r with
	   `key_success { A.st_priv_key = priv;
			  A.st_pub_key = pub;
			  A.st_netname = name
			} -> (name,pub,priv)
	 | `key_nosecret -> raise No_secret_key
	 | `key_unknown -> raise Netname_unknown
	 | `key_systemerr -> failwith "Rpc_key_service.net_get"
    )
;;


let shut_down =
  wrap_exn
    (fun keyserv ->
       match keyserv.client with
	   `Direct dclient -> Rpc_client.shut_down dclient
	 | _ -> ()
    )
;;