(* $Id: rpc_auth_gssapi.ml 1631 2011-06-16 15:04:56Z gerd $ *)
open Netgssapi
open Rpc_auth_gssapi_aux
open Printf
type support_level =
[ `Required | `If_possible | `None ]
type window =
{ window : string;
mutable window_length : int64;
mutable window_offset : int;
mutable window_last : int64;
}
type rpc_context =
{ context : context;
mutable ctx_continue : bool;
ctx_handle : string;
ctx_conn_id : Rpc_server.connection_id option;
mutable ctx_svc_none : bool;
(* whether unprotected messages are ok *)
mutable ctx_svc_integrity : bool;
(* whether integrity-protected msgs are ok *)
mutable ctx_svc_privacy : bool;
(* whether privacy-protected msgs are ok *)
ctx_window : window option;
}
type user_name_format =
[ `Exported_name
| `Prefixed_name
| `Plain_name
]
type user_name_interpretation =
[ `Exported_name
| `Prefixed_name
| `Plain_name of oid
]
module Debug = struct
let enable = ref false
end
let dlog = Netlog.Debug.mk_dlog "Rpc_auth_gssapi" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Rpc_auth_gssapi" Debug.enable
let () =
Netlog.Debug.register_module "Rpc_auth_gssapi" Debug.enable
let split_rpc_gss_data_t ms =
let ms_len = Xdr_mstring.length_mstrings ms in
if ms_len < 4 then
failwith "Rpc_auth_gssapi.split_rpc_gss_data_t";
let seq_s = Xdr_mstring.prefix_mstrings ms 4 in
let rest_s = Xdr_mstring.shared_sub_mstrings ms 4 (ms_len - 4) in
let seq = Rtypes.read_uint4 seq_s 0 in
(seq, rest_s)
let omax = Rtypes.mk_uint4 ('\255', '\255', '\255', '\255')
let integrity_encoder (gss_api : Netgssapi.gss_api)
ctx is_server cred1 rpc_gss_integ_data s =
dlog "integrity_encoder";
let data =
Xdr_mstring.string_to_mstring
(Rtypes.uint4_as_string cred1.seq_num) :: s in
let mic =
gss_api # get_mic
~context:ctx
~qop_req:None
~message:data
~out:(fun ~msg_token ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then (
if is_server then (
(* The RFC demands that no response is sent if a
get_mic problem occurs in the server
*)
Netlog.logf `Err
"Rpc_auth_gssapi: Cannot obtain MIC: %s"
(string_of_major_status major_status);
raise Rpc_server.Late_drop
)
else
failwith("Rpc_auth_gssapi: \
Cannot obtain MIC: " ^
string_of_major_status major_status);
);
msg_token
)
() in
(* The commented out code block performs two superflous string copies.
We avoid this by doing the XDR-ing manually.
*)
(*
let integ =
{ databody_integ = (Xdr_mstring.concat_mstrings data);
checksum = mic;
} in
let xdr_val = Rpc_auth_gssapi_aux._of_rpc_gss_integ_data integ in
Xdr.pack_xdr_value_as_string xdr_val rpc_gss_integ_data []
*)
let data_len = Xdr_mstring.length_mstrings data in
let data_decolen = Xdr.get_string_decoration_size data_len omax in
let data_hdr = Rtypes.uint4_as_string (Rtypes.uint4_of_int data_len) in
let data_padlen = data_decolen - 4 in
let data_pad = String.make data_padlen '\000' in
let mic_len = String.length mic in
let mic_decolen = Xdr.get_string_decoration_size mic_len omax in
let mic_hdr = Rtypes.uint4_as_string (Rtypes.uint4_of_int mic_len) in
let mic_padlen = mic_decolen - 4 in
let mic_pad = String.make mic_padlen '\000' in
[ Xdr_mstring.string_to_mstring data_hdr ] @
data @
[ Xdr_mstring.string_to_mstring (data_pad ^
mic_hdr ^ mic ^ mic_pad)
]
let ms_factories = Hashtbl.create 3
let () =
Hashtbl.add ms_factories "*" Xdr_mstring.string_based_mstrings
let integrity_decoder (gss_api : Netgssapi.gss_api)
ctx is_server cred1 rpc_gss_integ_data s pos len =
dlog "integrity_decoder";
try
let xdr_val, xdr_len =
Xdr.unpack_xdr_value_l
~pos ~len ~fast:true s rpc_gss_integ_data ~prefix:true
~mstring_factories:ms_factories
[] in
let integ =
_to_rpc_gss_integ_data xdr_val in
let data =
integ.databody_integ in
(* In the server, any integrity problem should be mapped
to GARBAGE. We get this by raising Xdr_format exceptions here.
*)
gss_api # verify_mic
~context:ctx
~message:[data]
~token:integ.checksum
~out:(fun ~qop_state ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
raise(Xdr.Xdr_format(
"Rpc_auth_gssapi: \
Cannot verify MIC: " ^
string_of_major_status major_status));
)
();
let (seq, args) =
split_rpc_gss_data_t [data] in
if seq <> cred1.seq_num then
raise(Xdr.Xdr_format "Rpc_auth_gssapi: bad sequence number");
dlog "integrity_decoder returns normally";
(Xdr_mstring.concat_mstrings args, xdr_len)
(* This "concat" is hard to avoid. We are still decoding strings,
not mstrings.
*)
with
| Xdr.Xdr_format _ as e ->
raise e
| e ->
raise(Xdr.Xdr_format
"Rpc_auth_gssapi: cannot decode integrity-proctected message")
let privacy_encoder (gss_api : Netgssapi.gss_api)
ctx is_server cred1 rpc_gss_priv_data s =
dlog "privacy_encoder";
let data =
Xdr_mstring.string_to_mstring
(Rtypes.uint4_as_string cred1.seq_num) :: s in
gss_api # wrap
~context:ctx
~conf_req:true
~qop_req:None
~input_message:data
~output_message_preferred_type:`String
~out:(fun ~conf_state ~output_message ~minor_status ~major_status () ->
try
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then (
failwith("Rpc_auth_gssapi: \
Cannot wrap message: " ^
string_of_major_status major_status);
);
if not conf_state then
failwith
"Rpc_auth_gssapi: no privacy-ensuring wrapping possible";
(* The commented out code block performs two superflous string copies.
We avoid this by doing the XDR-ing manually.
*)
let priv_len = Xdr_mstring.length_mstrings output_message in
let priv_decolen = Xdr.get_string_decoration_size priv_len omax in
let priv_hdr =
Rtypes.uint4_as_string (Rtypes.uint4_of_int priv_len) in
let priv_padlen = priv_decolen - 4 in
let priv_pad = String.make priv_padlen '\000' in
[ Xdr_mstring.string_to_mstring priv_hdr ] @
output_message @
[ Xdr_mstring.string_to_mstring priv_pad ]
(*
let priv =
{ databody_priv = output_message } in
let xdr_val = Rpc_auth_gssapi_aux._of_rpc_gss_priv_data priv in
Xdr.pack_xdr_value_as_mstring xdr_val rpc_gss_priv_data []
*)
with
| (Failure s | Xdr.Xdr_failure s) when is_server ->
(* The RFC demands that no response is sent if a
wrap problem occurs in the server
*)
Netlog.log `Err s;
raise Rpc_server.Late_drop
)
()
let privacy_decoder (gss_api : Netgssapi.gss_api)
ctx is_server cred1 rpc_gss_priv_data s pos len =
dlog "privacy_decoder";
try
let xdr_val, xdr_len =
Xdr.unpack_xdr_value_l
~pos ~len ~fast:true ~prefix:true s rpc_gss_priv_data
~mstring_factories:ms_factories
[] in
let priv =
_to_rpc_gss_priv_data xdr_val in
let data =
priv.databody_priv in
(* In the server, any integrity problem should be mapped
to GARBAGE. We get this by raising Xdr_format exceptions here.
*)
gss_api # unwrap
~context:ctx
~input_message:[data]
~output_message_preferred_type:`String
~out:(fun ~output_message ~conf_state ~qop_state ~minor_status
~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
raise(Xdr.Xdr_format
("Rpc_auth_gssapi: \
Cannot unwrap message: " ^
string_of_major_status major_status));
if not conf_state then
raise
(Xdr.Xdr_format
"Rpc_auth_gssapi: no privacy-ensuring unwrapping \
possible");
let (seq, args) =
split_rpc_gss_data_t output_message in
if seq <> cred1.seq_num then
raise(Xdr.Xdr_format "Rpc_auth_gssapi: bad sequence number");
dlog "privacy_decoder returns normally";
(Xdr_mstring.concat_mstrings args, xdr_len)
)
()
with
| Xdr.Xdr_format _ as e ->
raise e
| e ->
raise(Xdr.Xdr_format
"Rpc_auth_gssapi: cannot decode privacy-proctected message")
let init_window n =
let n' = ((n-1) / 8) + 1 in
{ window = String.make n' '\000';
window_length = 0L;
window_offset = 0;
window_last = 0L;
}
let check_seq_num w seq_num =
(* The interpretation is as follows:
- The window starts at window_last - window_length + 1
- The window ends at window_last
- The string window is seen as a bit string
- The first bit of the window is mapped to the bit window_offset
in window
returns true if the seq num is ok
*)
let l = String.length w.window * 8 in
let lL = Int64.of_int l in
let seq_numL = Rtypes.int64_of_uint4 seq_num in
if w.window_length = 0L then (
(* initialization. Assume ctx.ctx_window is filled with zeros *)
if seq_numL >= lL then
w.window_length <- lL
else
w.window_length <- Int64.succ seq_numL;
w.window_offset <- 0;
w.window_last <- seq_numL;
let n2 = Int64.to_int w.window_length - 1 in
let k = n2 lsr 3 in
let j = n2 land 7 in
let c = Char.code w.window.[k] in
let c' = c lor (1 lsl j) in
w.window.[k] <- Char.chr c';
true
)
else
if seq_numL > w.window_last then (
(* all ok, just advance the window *)
while seq_numL > w.window_last do
let next = Int64.succ w.window_last in
if w.window_length < lL then
w.window_length <- Int64.succ w.window_length
else
w.window_offset <- (succ w.window_offset) mod l;
let n2 =
(w.window_offset + Int64.to_int w.window_length - 1) mod l in
let k = n2 lsr 3 in
let j = n2 land 7 in
let c = Char.code w.window.[k] in
let c' =
if seq_numL = next then
c lor (1 lsl j)
else
c land (lnot (1 lsl j)) in
w.window.[k] <- Char.chr c';
w.window_last <- next
done;
true
) else
let before_start =
Int64.sub w.window_last w.window_length in
seq_numL > before_start && (
let n1 = Int64.to_int (Int64.pred (Int64.sub seq_numL before_start)) in
let n2 = (w.window_offset + n1) mod l in
let k = n2 lsr 3 in
let j = n2 land 7 in
let c = Char.code w.window.[k] in
let ok = (c land (1 lsl j)) = 0 in
if ok then (
let c' = c lor (1 lsl j) in
w.window.[k] <- Char.chr c';
);
ok
)
let server_auth_method
?(require_privacy=false)
?(require_integrity=false)
?(shared_context=false)
?acceptor_cred
?(user_name_format = `Prefixed_name)
?seq_number_window
(gss_api : gss_api) mech : Rpc_server.auth_method =
let acceptor_cred =
match acceptor_cred with
| None ->
gss_api # acquire_cred
~desired_name:gss_api#no_name
~time_req:`None
~desired_mechs:[mech]
~cred_usage:`Accept
~out:(
fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot acquire default creds: " ^
string_of_major_status major_status);
cred
)
()
| Some c -> c in
let rpc_gss_cred_t =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_cred_t in
let rpc_gss_init_arg =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_arg in
let rpc_gss_init_res =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_res in
let rpc_gss_integ_data =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_integ_data in
let rpc_gss_priv_data =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_priv_data in
let ctx_by_handle = Hashtbl.create 42 in
let handle_nr = ref 0 in
let new_handle() =
let n = !handle_nr in
incr handle_nr;
let random = String.make 16 '\000' in
Netsys_rng.fill_random random;
sprintf "%6d_%s" n (Digest.to_hex random) in
( object(self)
method name = "RPCSEC_GSS"
method flavors = [ "RPCSEC_GSS" ]
method peek = `None
method authenticate srv conn_id (details:Rpc_server.auth_details) auth =
dlog "authenticate";
(* First decode the rpc_gss_cred_t structure in the header: *)
try
let (_, cred_data) = details # credential in
let xdr_val =
try
Xdr.unpack_xdr_value
~fast:true
cred_data
rpc_gss_cred_t
[]
with _ ->
(* Bad credential *)
raise(Rpc.Rpc_server Rpc.Auth_bad_cred) in
let cred =
_to_rpc_gss_cred_t xdr_val in
match cred with
| `_1 cred1 ->
let r =
match cred1.gss_proc with
| `rpcsec_gss_init ->
self # auth_init srv conn_id details cred1
| `rpcsec_gss_continue_init ->
self # auth_cont_init srv conn_id details cred1
| `rpcsec_gss_destroy ->
self # auth_destroy srv conn_id details cred1
| `rpcsec_gss_data ->
self # auth_data srv conn_id details cred1
in
let () = auth r in
dlog "authenticate returns normally";
()
with
| Rpc.Rpc_server code ->
auth(Rpc_server.Auth_negative code)
| error ->
Netlog.logf `Err
"Failed RPC authentication (GSS-API): %s"
(Netexn.to_string error);
auth(Rpc_server.Auth_negative Rpc.Auth_failed)
method private get_token details =
let body_data =
Rpc_packer.unpack_call_body_raw
details#message details#frame_len in
let xdr_val =
Xdr.unpack_xdr_value
~fast:true
body_data
rpc_gss_init_arg
[] in
let token_struct =
_to_rpc_gss_init_arg xdr_val in
token_struct.gss_token
method private fixup_svc_flags ctx ret_flags =
let have_privacy = List.mem `Conf_flag ret_flags in
let have_integrity = List.mem `Integ_flag ret_flags in
if require_privacy && not have_privacy then
failwith
"Rpc_auth_gssapi: Privacy requested but unavailable";
if require_integrity && not have_integrity then
failwith
"Rpc_auth_gssapi: Integrity requested but unavailable";
ctx.ctx_svc_none <- not require_privacy && not require_integrity;
ctx.ctx_svc_integrity <- not require_privacy && have_integrity;
ctx.ctx_svc_privacy <- have_privacy;
method private verify_context ctx conn_id =
( match ctx.ctx_conn_id with
| None -> ()
| Some id ->
if id <> conn_id then
failwith "Rpc_auth_gssapi: this context is unavailable \
to this connection"
)
(* CHECK: do we need to inquire_context, and to check whether
the context is fully established?
*)
method private get_user ctx =
let name =
gss_api # inquire_context
~context:ctx.context
~out:(fun ~src_name ~targ_name ~lifetime_req ~mech_type
~ctx_flags ~locally_initiated ~is_open
~minor_status ~major_status
()
->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot extract name: "
^ string_of_major_status major_status);
if not is_open then
failwith("Rpc_auth_gssapi: get_user: context is not \
fully established");
src_name
(* this is guaranteed to be a mechanism name (MN),
so it is already canonicalized
*)
)
() in
if user_name_format = `Exported_name then
gss_api # export_name
~name
~out:(fun ~exported_name ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot export name: "
^ string_of_major_status major_status);
exported_name
)
()
else (
gss_api # display_name
~input_name:name
~out:(fun ~output_name ~output_name_type ~minor_status ~major_status
() ->
match user_name_format with
| `Exported_name -> assert false
| `Prefixed_name ->
let oid_s =
Netgssapi.oid_to_string output_name_type in
oid_s ^ output_name
| `Plain_name ->
output_name
)
()
)
method private auth_init srv conn_id details cred1 =
dlog "auth_init";
let (verf_flav, verf_data) = details # verifier in
if details#procedure <> Rtypes.uint4_of_int 0 then
failwith "For context initialization the RPC procedure must be 0";
if cred1.handle <> "" then
failwith "Context handle is not empty";
if verf_flav <> "AUTH_NONE" then
failwith "Bad verifier (1)";
if verf_data <> "" then
failwith "Bad verifier (2)";
gss_api # accept_sec_context
~context:None
~acceptor_cred
~input_token:(self # get_token details)
~chan_bindings:None
~out:(
fun ~src_name ~mech_type ~output_context
~output_token ~ret_flags ~time_rec
~delegated_cred ~minor_status ~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot accept token: " ^
string_of_major_status major_status);
let h = new_handle() in
let context =
match output_context with
| None ->
failwith "Rpc_auth_gssapi: no context"
| Some c -> c in
let cont = List.mem `Continue_needed flags in
let ctx =
{ context = context;
ctx_continue = cont;
ctx_handle = h;
ctx_conn_id =
if shared_context then None else Some conn_id;
ctx_svc_none = false;
ctx_svc_integrity = false;
ctx_svc_privacy = false;
ctx_window = ( match seq_number_window with
| None -> None
| Some n -> Some(init_window n)
);
} in
if not cont then
self#fixup_svc_flags ctx ret_flags;
Hashtbl.replace ctx_by_handle h ctx;
let reply =
{ res_handle = h;
res_major =
if ctx.ctx_continue
then gss_s_continue_needed
else gss_s_complete;
res_minor = zero;
res_seq_window = ( match seq_number_window with
| None ->
maxseq
| Some n ->
Rtypes.uint4_of_int n
);
res_token = output_token
} in
self # auth_init_result ctx reply
)
()
method private auth_cont_init srv conn_id details cred1 =
dlog "auth_cont_init";
let (verf_flav, verf_data) = details # verifier in
if details#procedure <> Rtypes.uint4_of_int 0 then
failwith "For context initialization the RPC procedure must be 0";
if verf_flav <> "AUTH_NONE" then
failwith "Bad verifier (1)";
if verf_data <> "" then
failwith "Bad verifier (2)";
let h = cred1.handle in
let ctx =
try Hashtbl.find ctx_by_handle h
with Not_found ->
failwith "Rpc_auth_gssapi: unknown context handle" in
if not ctx.ctx_continue then
failwith "Rpc_auth_gssapi: cannot continue context establishment";
self # verify_context ctx conn_id;
gss_api # accept_sec_context
~context:(Some ctx.context)
~acceptor_cred
~input_token:(self # get_token details)
~chan_bindings:None
~out:(
fun ~src_name ~mech_type ~output_context
~output_token ~ret_flags ~time_rec
~delegated_cred ~minor_status ~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot accept token: " ^
string_of_major_status major_status);
(* CHECK: do we need to check whether output_context is
the current context? Can this change?
*)
ctx.ctx_continue <- List.mem `Continue_needed flags;
if not ctx.ctx_continue then
self#fixup_svc_flags ctx ret_flags;
let reply =
{ res_handle = h;
res_major =
if ctx.ctx_continue
then gss_s_continue_needed
else gss_s_complete;
res_minor = zero;
res_seq_window = ( match seq_number_window with
| None ->
maxseq
| Some n ->
Rtypes.uint4_of_int n
);
res_token = output_token
} in
self # auth_init_result ctx reply
)
()
method private auth_init_result ctx reply =
dlog "auth_init_result";
let xdr_val =
Rpc_auth_gssapi_aux._of_rpc_gss_init_res reply in
let m =
Xdr.pack_xdr_value_as_mstrings
xdr_val rpc_gss_init_res [] in
let (verf_flav, verf_data) =
if ctx.ctx_continue then
("AUTH_NONE", "")
else
let window_s =
Rtypes.uint4_as_string reply.res_seq_window in
let mic =
gss_api # get_mic
~context:ctx.context
~qop_req:None
~message:[Xdr_mstring.string_to_mstring window_s]
~out:(fun ~msg_token ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: \
Cannot compute MIC: " ^
string_of_major_status major_status);
msg_token
)
() in
("RPCSEC_GSS", mic) in
Rpc_server.Auth_reply(m, verf_flav, verf_data)
method private auth_data srv conn_id details cred1 =
dlog "auth_data";
(* Get context: *)
let h = cred1.handle in
let ctx =
try Hashtbl.find ctx_by_handle h
with Not_found ->
failwith "Rpc_auth_gssapi: unknown context handle" in
self # verify_context ctx conn_id;
(* Verify the header first *)
let (verf_flav, verf_data) = details # verifier in
if verf_flav <> "RPCSEC_GSS" then
failwith "Rpc_auth_gssapi: Bad type of verifier";
let pv = details # message in
let n = Rpc_packer.extract_call_gssapi_header pv in
let s = Rpc_packer.prefix_of_packed_value pv n in
gss_api # verify_mic
~context:ctx.context
~message:[Xdr_mstring.string_to_mstring s]
~token:verf_data
~out:(fun ~qop_state ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_credproblem)
(* demanded by the RFC *)
(*
failwith("Rpc_auth_gssapi: \
Cannot verify MIC: " ^
string_of_major_status major_status);
*)
)
();
(* FIXME: we should also check here whether the credentials'
lifetime is over, and if so, report RPCSEC_GSS_ctxproblem.
We cannot delay this until encoding/decoding because the
exception handling would not work by then. So it must
happen now. I have no idea how to do so, though.
*)
(* Check sequence number *)
if Rtypes.gt_uint4 cred1.seq_num maxseq then
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_ctxproblem);
let drop =
match ctx.ctx_window with
| None -> false
| Some w ->
not (check_seq_num w cred1.seq_num) in
if drop then
Rpc_server.Auth_drop
else
match cred1.service with
| `rpc_gss_svc_none ->
if not ctx.ctx_svc_none then
failwith "Rpc_auth_gssapi: unexpected unprotected message";
self#auth_data_result ctx cred1.seq_num None None;
| `rpc_gss_svc_integrity ->
if not ctx.ctx_svc_integrity then
failwith "Rpc_auth_gssapi: unexpected integrity-proctected \
message";
let encoder =
integrity_encoder
gss_api ctx.context true cred1 rpc_gss_integ_data in
let decoder =
integrity_decoder
gss_api ctx.context true cred1 rpc_gss_integ_data in
self#auth_data_result
ctx cred1.seq_num (Some encoder) (Some decoder)
| `rpc_gss_svc_privacy ->
if not ctx.ctx_svc_privacy then
failwith "Rpc_auth_gssapi: unexpected privacy-proctected \
message";
let encoder =
privacy_encoder
gss_api ctx.context true cred1 rpc_gss_priv_data in
let decoder =
privacy_decoder gss_api ctx.context true
cred1 rpc_gss_priv_data in
self # auth_data_result
ctx cred1.seq_num (Some encoder) (Some decoder)
method private auth_data_result ctx seq enc_opt dec_opt =
dlog "auth_data_result";
let seq_s =
Rtypes.uint4_as_string seq in
let mic =
gss_api # get_mic
~context:ctx.context
~qop_req:None
~message:[Xdr_mstring.string_to_mstring seq_s]
~out:(fun ~msg_token ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_ctxproblem);
(*
failwith("Rpc_auth_gssapi: \
Cannot compute MIC: " ^
string_of_major_status major_status);
*)
msg_token
)
() in
Rpc_server.Auth_positive(
self#get_user ctx,
"RPCSEC_GSS", mic, enc_opt, dec_opt
)
method private auth_destroy srv conn_id details cred1 =
dlog "auth_destroy";
if details#procedure <> Rtypes.uint4_of_int 0 then
failwith "For context destruction the RPC procedure must be 0";
let r =
self # auth_data srv conn_id details cred1 in
match r with
| Rpc_server.Auth_positive(_, flav, mic, enc_opt, dec_opt) ->
(* Check that the input args are empty: *)
let raw_body =
Rpc_packer.unpack_call_body_raw
details#message details#frame_len in
let body_length =
match dec_opt with
| None -> String.length raw_body
| Some dec ->
let (b,n) = dec raw_body 0 (String.length raw_body) in
n in
if body_length <> 0 then
failwith "Rpc_auth_gssapi: invalid destroy request";
(* Now destroy: *)
let h = cred1.handle in
Hashtbl.remove ctx_by_handle h;
(* Create response: *)
let encoded_emptiness =
match enc_opt with
| None -> []
| Some enc -> enc [] in
(* Respond: *)
Rpc_server.Auth_reply(encoded_emptiness, flav, mic)
| _ ->
r
end
)
let client_auth_method
?(privacy=`If_possible)
?(integrity=`If_possible)
?(user_name_interpretation = `Prefixed_name)
(gss_api : gss_api) mech : Rpc_client.auth_method =
let default_initiator_cred() =
gss_api # acquire_cred
~desired_name:gss_api#no_name
~time_req:`None
~desired_mechs:[mech]
~cred_usage:`Initiate
~out:(
fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot acquire default creds: " ^
string_of_major_status major_status);
cred
)
() in
let rpc_gss_cred_t =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_cred_t in
let rpc_gss_integ_data =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_integ_data in
let rpc_gss_priv_data =
Xdr.validate_xdr_type
Rpc_auth_gssapi_aux.xdrt_rpc_gss_priv_data in
let session (m:Rpc_client.auth_method)
(p:Rpc_client.auth_protocol)
ctx service handle cur_seq_num
: Rpc_client.auth_session =
let seq_num_of_xid = Hashtbl.create 15 in
( object(self)
method next_credentials client prog proc xid =
(* N.B. Exceptions raised here probably abort the client,
and fall through to the event loop
*)
dlogr
(fun () ->
sprintf "next_credentials proc=%s xid=%Ld"
proc (Rtypes.int64_of_uint4 xid)
);
let cred1 =
{ gss_proc = `rpcsec_gss_data;
seq_num = !cur_seq_num;
service = service;
handle = handle
} in
let cred1_xdr = _of_rpc_gss_cred_t (`_1 cred1) in
let cred1_s =
Xdr.pack_xdr_value_as_string
cred1_xdr rpc_gss_cred_t [] in
let h_pv =
Rpc_packer.pack_call_gssapi_header
prog xid proc "RPCSEC_GSS" cred1_s in
let h =
Rpc_packer.string_of_packed_value h_pv in
let mic =
gss_api # get_mic
~context:ctx
~qop_req:None
~message:[Xdr_mstring.string_to_mstring h]
~out:(fun ~msg_token ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: \
Cannot obtain MIC: " ^
string_of_major_status major_status);
msg_token
)
() in
(* Save seq_num: *)
Hashtbl.replace seq_num_of_xid xid !cur_seq_num;
(* Increment cur_seq_num: *)
cur_seq_num :=
Rtypes.uint4_of_int64(
Int64.logand
(Int64.succ (Rtypes.int64_of_uint4 !cur_seq_num))
0xFFFF_FFFFL
);
let enc_opt, dec_opt =
match service with
| `rpc_gss_svc_none ->
None, None
| `rpc_gss_svc_integrity ->
let encoder =
integrity_encoder
gss_api ctx false cred1 rpc_gss_integ_data in
let decoder =
integrity_decoder
gss_api ctx false cred1 rpc_gss_integ_data in
(Some encoder), (Some decoder)
| `rpc_gss_svc_privacy ->
let encoder =
privacy_encoder gss_api ctx false cred1 rpc_gss_priv_data in
let decoder =
privacy_decoder gss_api ctx false cred1 rpc_gss_priv_data in
(Some encoder), (Some decoder) in
dlogr
(fun () ->
sprintf "next_credentials returns normally"
);
("RPCSEC_GSS", cred1_s,
"RPCSEC_GSS", mic,
enc_opt, dec_opt
)
method server_rejects client xid code =
dlogr
(fun () ->
sprintf "server_rejects xid=%Ld"
(Rtypes.int64_of_uint4 xid)
);
Hashtbl.remove seq_num_of_xid xid;
match code with
| Rpc.RPCSEC_GSS_credproblem | Rpc.RPCSEC_GSS_ctxproblem ->
`Renew
| Rpc.Auth_too_weak ->
`Next
| _ ->
`Fail
method server_accepts client xid verf_flav verf_data =
dlogr
(fun () ->
sprintf "server_accepts xid=%Ld"
(Rtypes.int64_of_uint4 xid)
);
if verf_flav <> "RPCSEC_GSS" then
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp);
let seq =
try Hashtbl.find seq_num_of_xid xid
with Not_found ->
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp) in
let seq_s =
Rtypes.uint4_as_string seq in
Hashtbl.remove seq_num_of_xid xid;
gss_api # verify_mic
~context:ctx
~message:[Xdr_mstring.string_to_mstring seq_s]
~token:verf_data
~out:(fun ~qop_state ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp);
)
();
dlog "server_accepts returns normally"
method auth_protocol = p
end
) in
let protocol (m:Rpc_client.auth_method) client cred
: Rpc_client.auth_protocol =
let first = ref true in
let state = ref `Emit in
let ctx = ref None in
let input_token = ref "" in
let handle = ref "" in
let init_prog = ref None in
let init_service = ref None in
let get_context() =
match !ctx with Some c -> c | None -> assert false in
(* CHECK: what happens with exceptions thrown here? *)
( object(self)
method state = !state
method emit xid prog_nr vers_nr =
assert(!state = `Emit);
dlogr
(fun () ->
sprintf "emit prog_nr=%Ld vers_nr=%Ld xid=%Ld"
(Rtypes.int64_of_uint4 prog_nr)
(Rtypes.int64_of_uint4 vers_nr)
(Rtypes.int64_of_uint4 xid)
);
try
let prog =
match !init_prog with
| None ->
let p =
Rpc_program.create
prog_nr
vers_nr
(Xdr.validate_xdr_type_system [])
[ "init",
( (Rtypes.uint4_of_int 0),
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_arg,
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_res
);
] in
init_prog := Some p;
p
| Some p -> p in
let req_flags =
( if integrity=`If_possible || integrity=`Required then
[ `Integ_flag ]
else
[]
) @
( if privacy=`If_possible || privacy=`Required then
[ `Conf_flag ]
else
[]
) in
let (output_token, cont_needed, have_priv, have_integ) =
gss_api # init_sec_context
~initiator_cred:cred
~context:!ctx
~target_name:gss_api#no_name
~mech_type:[||]
~req_flags
~time_rec:None
~chan_bindings:None
~input_token:(if !first then None else Some !input_token)
~out:(fun ~actual_mech_type ~output_context ~output_token
~ret_flags ~time_rec ~minor_status ~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: Cannot init sec ctx: " ^
string_of_major_status major_status);
ctx := output_context;
(output_token,
List.mem `Continue_needed flags,
List.mem `Conf_flag ret_flags,
List.mem `Integ_flag ret_flags
)
)
() in
let service_i =
match integrity with
| `Required ->
if not have_integ && not have_priv then
failwith "Rpc_auth_gssapi: Integrity is not available";
`rpc_gss_svc_integrity
| `If_possible ->
if have_integ then
`rpc_gss_svc_integrity
else
`rpc_gss_svc_none
| `None ->
`rpc_gss_svc_none in
let service =
match privacy with
| `Required ->
if not have_priv then
failwith "Rpc_auth_gssapi: Privacy is not available";
`rpc_gss_svc_privacy
| `If_possible ->
if have_priv then
`rpc_gss_svc_privacy
else
service_i
| `None ->
service_i in
init_service := Some service;
let cred1 =
`_1 { gss_proc = ( if !first then `rpcsec_gss_init
else `rpcsec_gss_continue_init );
seq_num = Rtypes.uint4_of_int 0; (* FIXME *)
service = service;
handle = !handle
} in
let cred1_xdr = _of_rpc_gss_cred_t cred1 in
let cred1_s =
Xdr.pack_xdr_value_as_string
cred1_xdr rpc_gss_cred_t [] in
let pv =
Rpc_packer.pack_call
prog xid "init"
"RPCSEC_GSS" cred1_s
"AUTH_NONE" ""
(Xdr.XV_struct_fast [| Xdr.XV_opaque output_token |] ) in
first := false;
state := `Receive xid;
dlog "emit returns normally";
pv
with error ->
Netlog.logf `Err
"Rpc_auth_gssapi: Error during message preparation: %s"
(Netexn.to_string error);
state := `Error;
raise error
method receive pv =
try
dlog "receive";
let prog =
match !init_prog with
| None -> assert false
| Some p -> p in
let (xid, flav_name, flav_data, result_xdr) =
Rpc_packer.unpack_reply prog "init" pv in
assert( !state = `Receive xid );
dlogr
(fun () ->
sprintf "receive xid=%Ld"
(Rtypes.int64_of_uint4 xid)
);
let res = _to_rpc_gss_init_res result_xdr in
let cont_needed =
res.res_major = gss_s_continue_needed in
if not cont_needed && res.res_major <> gss_s_complete then
failwith
(sprintf "Rpc_auth_gssapi: Got GSS-API error code %Ld"
(Rtypes.int64_of_uint4 res.res_major));
if cont_needed then (
if flav_name <> "AUTH_NONE" || flav_data <> "" then
failwith "Rpc_auth_gssapi: bad verifier";
)
else (
if flav_name <> "RPCSEC_GSS" then
failwith "Rpc_auth_gssapi: bad verifier";
let window_s =
Rtypes.uint4_as_string res.res_seq_window in
gss_api # verify_mic
~context:(get_context())
~message:[Xdr_mstring.string_to_mstring window_s]
~token:flav_data
~out:(fun ~qop_state ~minor_status ~major_status () ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith("Rpc_auth_gssapi: \
Cannot verify MIC: " ^
string_of_major_status major_status);
()
)
()
);
handle := res.res_handle;
input_token := res.res_token;
if cont_needed then
state := `Emit
else
let c = get_context () in
let service =
match !init_service with Some s -> s | None -> assert false in
let cs = ref (Rtypes.uint4_of_int 0) in
let s =
session
m (self :> Rpc_client.auth_protocol) c service !handle cs in
state := `Done s;
dlog "receive returns normally";
with error ->
Netlog.logf `Err
"Rpc_auth_gssapi: Error during message verification: %s"
(Netexn.to_string error);
state := `Error;
raise error
method auth_method = m
end
) in
( object(self)
method name = "RPCSEC_GSS"
method new_session client user_opt =
dlogr
(fun () ->
sprintf "new_session user=%s"
(match user_opt with
| None -> "-" | Some u -> u
)
);
let cred =
match user_opt with
| None ->
default_initiator_cred()
| Some user ->
let (input_name, input_name_type) =
match user_name_interpretation with
| `Exported_name ->
(user, nt_export_name)
| `Prefixed_name ->
let l = String.length user in
( try
let k = String.index user '}' in
let oid = string_to_oid (String.sub user 0 (k+1)) in
let n = String.sub user (k+1) (l-k-1) in
(n, oid)
with _ ->
failwith
("Rpc_auth_gssapi: cannot parse user name")
)
| `Plain_name input_name_type ->
(user, input_name_type) in
let name =
gss_api # import_name
~input_name
~input_name_type
~out:(fun ~output_name ~minor_status ~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith
("Rpc_auth_gssapi: Cannot import name: "
^ string_of_major_status major_status);
output_name
)
() in
gss_api # acquire_cred
~desired_name:name
~time_req:`None
~desired_mechs:[mech]
~cred_usage:`Initiate
~out:(
fun ~cred ~actual_mechs ~time_rec ~minor_status
~major_status
() ->
let (c_err, r_err, flags) = major_status in
if c_err <> `None || r_err <> `None then
failwith
("Rpc_auth_gssapi: Cannot acquire default creds: "
^ string_of_major_status major_status);
cred
)
() in
protocol (self :> Rpc_client.auth_method) client cred
end
)
