(* $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 | _ -> () ) ;;