1
(* $Id: rpc_auth_gssapi.ml 1631 2011-06-16 15:04:56Z gerd $ *)
4
open Rpc_auth_gssapi_aux
8
[ `Required | `If_possible | `None ]
12
mutable window_length : int64;
13
mutable window_offset : int;
14
mutable window_last : int64;
19
mutable ctx_continue : bool;
21
ctx_conn_id : Rpc_server.connection_id option;
22
mutable ctx_svc_none : bool;
23
(* whether unprotected messages are ok *)
24
mutable ctx_svc_integrity : bool;
25
(* whether integrity-protected msgs are ok *)
26
mutable ctx_svc_privacy : bool;
27
(* whether privacy-protected msgs are ok *)
29
ctx_window : window option;
32
type user_name_format =
38
type user_name_interpretation =
45
let enable = ref false
48
let dlog = Netlog.Debug.mk_dlog "Rpc_auth_gssapi" Debug.enable
49
let dlogr = Netlog.Debug.mk_dlogr "Rpc_auth_gssapi" Debug.enable
52
Netlog.Debug.register_module "Rpc_auth_gssapi" Debug.enable
55
let split_rpc_gss_data_t ms =
56
let ms_len = Xdr_mstring.length_mstrings ms in
58
failwith "Rpc_auth_gssapi.split_rpc_gss_data_t";
59
let seq_s = Xdr_mstring.prefix_mstrings ms 4 in
60
let rest_s = Xdr_mstring.shared_sub_mstrings ms 4 (ms_len - 4) in
61
let seq = Rtypes.read_uint4 seq_s 0 in
65
let omax = Rtypes.mk_uint4 ('\255', '\255', '\255', '\255')
67
let integrity_encoder (gss_api : Netgssapi.gss_api)
68
ctx is_server cred1 rpc_gss_integ_data s =
69
dlog "integrity_encoder";
71
Xdr_mstring.string_to_mstring
72
(Rtypes.uint4_as_string cred1.seq_num) :: s in
78
~out:(fun ~msg_token ~minor_status ~major_status () ->
79
let (c_err, r_err, flags) = major_status in
80
if c_err <> `None || r_err <> `None then (
82
(* The RFC demands that no response is sent if a
83
get_mic problem occurs in the server
86
"Rpc_auth_gssapi: Cannot obtain MIC: %s"
87
(string_of_major_status major_status);
88
raise Rpc_server.Late_drop
91
failwith("Rpc_auth_gssapi: \
92
Cannot obtain MIC: " ^
93
string_of_major_status major_status);
98
(* The commented out code block performs two superflous string copies.
99
We avoid this by doing the XDR-ing manually.
103
{ databody_integ = (Xdr_mstring.concat_mstrings data);
106
let xdr_val = Rpc_auth_gssapi_aux._of_rpc_gss_integ_data integ in
107
Xdr.pack_xdr_value_as_string xdr_val rpc_gss_integ_data []
109
let data_len = Xdr_mstring.length_mstrings data in
110
let data_decolen = Xdr.get_string_decoration_size data_len omax in
111
let data_hdr = Rtypes.uint4_as_string (Rtypes.uint4_of_int data_len) in
112
let data_padlen = data_decolen - 4 in
113
let data_pad = String.make data_padlen '\000' in
115
let mic_len = String.length mic in
116
let mic_decolen = Xdr.get_string_decoration_size mic_len omax in
117
let mic_hdr = Rtypes.uint4_as_string (Rtypes.uint4_of_int mic_len) in
118
let mic_padlen = mic_decolen - 4 in
119
let mic_pad = String.make mic_padlen '\000' in
121
[ Xdr_mstring.string_to_mstring data_hdr ] @
123
[ Xdr_mstring.string_to_mstring (data_pad ^
124
mic_hdr ^ mic ^ mic_pad)
129
let ms_factories = Hashtbl.create 3
132
Hashtbl.add ms_factories "*" Xdr_mstring.string_based_mstrings
135
let integrity_decoder (gss_api : Netgssapi.gss_api)
136
ctx is_server cred1 rpc_gss_integ_data s pos len =
137
dlog "integrity_decoder";
139
let xdr_val, xdr_len =
140
Xdr.unpack_xdr_value_l
141
~pos ~len ~fast:true s rpc_gss_integ_data ~prefix:true
142
~mstring_factories:ms_factories
145
_to_rpc_gss_integ_data xdr_val in
147
integ.databody_integ in
148
(* In the server, any integrity problem should be mapped
149
to GARBAGE. We get this by raising Xdr_format exceptions here.
154
~token:integ.checksum
155
~out:(fun ~qop_state ~minor_status ~major_status () ->
156
let (c_err, r_err, flags) = major_status in
157
if c_err <> `None || r_err <> `None then
158
raise(Xdr.Xdr_format(
160
Cannot verify MIC: " ^
161
string_of_major_status major_status));
165
split_rpc_gss_data_t [data] in
166
if seq <> cred1.seq_num then
167
raise(Xdr.Xdr_format "Rpc_auth_gssapi: bad sequence number");
168
dlog "integrity_decoder returns normally";
169
(Xdr_mstring.concat_mstrings args, xdr_len)
170
(* This "concat" is hard to avoid. We are still decoding strings,
174
| Xdr.Xdr_format _ as e ->
178
"Rpc_auth_gssapi: cannot decode integrity-proctected message")
181
let privacy_encoder (gss_api : Netgssapi.gss_api)
182
ctx is_server cred1 rpc_gss_priv_data s =
183
dlog "privacy_encoder";
185
Xdr_mstring.string_to_mstring
186
(Rtypes.uint4_as_string cred1.seq_num) :: s in
192
~output_message_preferred_type:`String
193
~out:(fun ~conf_state ~output_message ~minor_status ~major_status () ->
195
let (c_err, r_err, flags) = major_status in
196
if c_err <> `None || r_err <> `None then (
197
failwith("Rpc_auth_gssapi: \
198
Cannot wrap message: " ^
199
string_of_major_status major_status);
201
if not conf_state then
203
"Rpc_auth_gssapi: no privacy-ensuring wrapping possible";
204
(* The commented out code block performs two superflous string copies.
205
We avoid this by doing the XDR-ing manually.
207
let priv_len = Xdr_mstring.length_mstrings output_message in
208
let priv_decolen = Xdr.get_string_decoration_size priv_len omax in
210
Rtypes.uint4_as_string (Rtypes.uint4_of_int priv_len) in
211
let priv_padlen = priv_decolen - 4 in
212
let priv_pad = String.make priv_padlen '\000' in
213
[ Xdr_mstring.string_to_mstring priv_hdr ] @
215
[ Xdr_mstring.string_to_mstring priv_pad ]
218
{ databody_priv = output_message } in
219
let xdr_val = Rpc_auth_gssapi_aux._of_rpc_gss_priv_data priv in
220
Xdr.pack_xdr_value_as_mstring xdr_val rpc_gss_priv_data []
223
| (Failure s | Xdr.Xdr_failure s) when is_server ->
224
(* The RFC demands that no response is sent if a
225
wrap problem occurs in the server
228
raise Rpc_server.Late_drop
232
let privacy_decoder (gss_api : Netgssapi.gss_api)
233
ctx is_server cred1 rpc_gss_priv_data s pos len =
234
dlog "privacy_decoder";
236
let xdr_val, xdr_len =
237
Xdr.unpack_xdr_value_l
238
~pos ~len ~fast:true ~prefix:true s rpc_gss_priv_data
239
~mstring_factories:ms_factories
242
_to_rpc_gss_priv_data xdr_val in
244
priv.databody_priv in
245
(* In the server, any integrity problem should be mapped
246
to GARBAGE. We get this by raising Xdr_format exceptions here.
250
~input_message:[data]
251
~output_message_preferred_type:`String
252
~out:(fun ~output_message ~conf_state ~qop_state ~minor_status
255
let (c_err, r_err, flags) = major_status in
256
if c_err <> `None || r_err <> `None then
259
Cannot unwrap message: " ^
260
string_of_major_status major_status));
261
if not conf_state then
264
"Rpc_auth_gssapi: no privacy-ensuring unwrapping \
267
split_rpc_gss_data_t output_message in
268
if seq <> cred1.seq_num then
269
raise(Xdr.Xdr_format "Rpc_auth_gssapi: bad sequence number");
270
dlog "privacy_decoder returns normally";
271
(Xdr_mstring.concat_mstrings args, xdr_len)
275
| Xdr.Xdr_format _ as e ->
279
"Rpc_auth_gssapi: cannot decode privacy-proctected message")
283
let n' = ((n-1) / 8) + 1 in
284
{ window = String.make n' '\000';
291
let check_seq_num w seq_num =
292
(* The interpretation is as follows:
293
- The window starts at window_last - window_length + 1
294
- The window ends at window_last
295
- The string window is seen as a bit string
296
- The first bit of the window is mapped to the bit window_offset
299
returns true if the seq num is ok
301
let l = String.length w.window * 8 in
302
let lL = Int64.of_int l in
303
let seq_numL = Rtypes.int64_of_uint4 seq_num in
304
if w.window_length = 0L then (
305
(* initialization. Assume ctx.ctx_window is filled with zeros *)
306
if seq_numL >= lL then
307
w.window_length <- lL
309
w.window_length <- Int64.succ seq_numL;
310
w.window_offset <- 0;
311
w.window_last <- seq_numL;
312
let n2 = Int64.to_int w.window_length - 1 in
315
let c = Char.code w.window.[k] in
316
let c' = c lor (1 lsl j) in
317
w.window.[k] <- Char.chr c';
321
if seq_numL > w.window_last then (
322
(* all ok, just advance the window *)
323
while seq_numL > w.window_last do
324
let next = Int64.succ w.window_last in
325
if w.window_length < lL then
326
w.window_length <- Int64.succ w.window_length
328
w.window_offset <- (succ w.window_offset) mod l;
330
(w.window_offset + Int64.to_int w.window_length - 1) mod l in
333
let c = Char.code w.window.[k] in
335
if seq_numL = next then
338
c land (lnot (1 lsl j)) in
339
w.window.[k] <- Char.chr c';
340
w.window_last <- next
345
Int64.sub w.window_last w.window_length in
346
seq_numL > before_start && (
347
let n1 = Int64.to_int (Int64.pred (Int64.sub seq_numL before_start)) in
348
let n2 = (w.window_offset + n1) mod l in
351
let c = Char.code w.window.[k] in
352
let ok = (c land (1 lsl j)) = 0 in
354
let c' = c lor (1 lsl j) in
355
w.window.[k] <- Char.chr c';
361
let server_auth_method
362
?(require_privacy=false)
363
?(require_integrity=false)
364
?(shared_context=false)
366
?(user_name_format = `Prefixed_name)
368
(gss_api : gss_api) mech : Rpc_server.auth_method =
371
match acceptor_cred with
373
gss_api # acquire_cred
374
~desired_name:gss_api#no_name
376
~desired_mechs:[mech]
379
fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status() ->
380
let (c_err, r_err, flags) = major_status in
381
if c_err <> `None || r_err <> `None then
382
failwith("Rpc_auth_gssapi: Cannot acquire default creds: " ^
383
string_of_major_status major_status);
390
Xdr.validate_xdr_type
391
Rpc_auth_gssapi_aux.xdrt_rpc_gss_cred_t in
393
let rpc_gss_init_arg =
394
Xdr.validate_xdr_type
395
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_arg in
397
let rpc_gss_init_res =
398
Xdr.validate_xdr_type
399
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_res in
401
let rpc_gss_integ_data =
402
Xdr.validate_xdr_type
403
Rpc_auth_gssapi_aux.xdrt_rpc_gss_integ_data in
405
let rpc_gss_priv_data =
406
Xdr.validate_xdr_type
407
Rpc_auth_gssapi_aux.xdrt_rpc_gss_priv_data in
410
let ctx_by_handle = Hashtbl.create 42 in
412
let handle_nr = ref 0 in
415
let n = !handle_nr in
417
let random = String.make 16 '\000' in
418
Netsys_rng.fill_random random;
419
sprintf "%6d_%s" n (Digest.to_hex random) in
422
method name = "RPCSEC_GSS"
424
method flavors = [ "RPCSEC_GSS" ]
428
method authenticate srv conn_id (details:Rpc_server.auth_details) auth =
430
(* First decode the rpc_gss_cred_t structure in the header: *)
432
let (_, cred_data) = details # credential in
442
raise(Rpc.Rpc_server Rpc.Auth_bad_cred) in
444
_to_rpc_gss_cred_t xdr_val in
448
match cred1.gss_proc with
449
| `rpcsec_gss_init ->
450
self # auth_init srv conn_id details cred1
451
| `rpcsec_gss_continue_init ->
452
self # auth_cont_init srv conn_id details cred1
453
| `rpcsec_gss_destroy ->
454
self # auth_destroy srv conn_id details cred1
455
| `rpcsec_gss_data ->
456
self # auth_data srv conn_id details cred1
459
dlog "authenticate returns normally";
462
| Rpc.Rpc_server code ->
463
auth(Rpc_server.Auth_negative code)
466
"Failed RPC authentication (GSS-API): %s"
467
(Netexn.to_string error);
468
auth(Rpc_server.Auth_negative Rpc.Auth_failed)
470
method private get_token details =
472
Rpc_packer.unpack_call_body_raw
473
details#message details#frame_len in
481
_to_rpc_gss_init_arg xdr_val in
482
token_struct.gss_token
485
method private fixup_svc_flags ctx ret_flags =
486
let have_privacy = List.mem `Conf_flag ret_flags in
487
let have_integrity = List.mem `Integ_flag ret_flags in
489
if require_privacy && not have_privacy then
491
"Rpc_auth_gssapi: Privacy requested but unavailable";
492
if require_integrity && not have_integrity then
494
"Rpc_auth_gssapi: Integrity requested but unavailable";
496
ctx.ctx_svc_none <- not require_privacy && not require_integrity;
497
ctx.ctx_svc_integrity <- not require_privacy && have_integrity;
498
ctx.ctx_svc_privacy <- have_privacy;
501
method private verify_context ctx conn_id =
502
( match ctx.ctx_conn_id with
505
if id <> conn_id then
506
failwith "Rpc_auth_gssapi: this context is unavailable \
509
(* CHECK: do we need to inquire_context, and to check whether
510
the context is fully established?
513
method private get_user ctx =
515
gss_api # inquire_context
517
~out:(fun ~src_name ~targ_name ~lifetime_req ~mech_type
518
~ctx_flags ~locally_initiated ~is_open
519
~minor_status ~major_status
522
let (c_err, r_err, flags) = major_status in
523
if c_err <> `None || r_err <> `None then
524
failwith("Rpc_auth_gssapi: Cannot extract name: "
525
^ string_of_major_status major_status);
527
failwith("Rpc_auth_gssapi: get_user: context is not \
530
(* this is guaranteed to be a mechanism name (MN),
531
so it is already canonicalized
535
if user_name_format = `Exported_name then
536
gss_api # export_name
538
~out:(fun ~exported_name ~minor_status ~major_status () ->
539
let (c_err, r_err, flags) = major_status in
540
if c_err <> `None || r_err <> `None then
541
failwith("Rpc_auth_gssapi: Cannot export name: "
542
^ string_of_major_status major_status);
547
gss_api # display_name
549
~out:(fun ~output_name ~output_name_type ~minor_status ~major_status
551
match user_name_format with
552
| `Exported_name -> assert false
555
Netgssapi.oid_to_string output_name_type in
565
method private auth_init srv conn_id details cred1 =
567
let (verf_flav, verf_data) = details # verifier in
568
if details#procedure <> Rtypes.uint4_of_int 0 then
569
failwith "For context initialization the RPC procedure must be 0";
570
if cred1.handle <> "" then
571
failwith "Context handle is not empty";
572
if verf_flav <> "AUTH_NONE" then
573
failwith "Bad verifier (1)";
574
if verf_data <> "" then
575
failwith "Bad verifier (2)";
576
gss_api # accept_sec_context
579
~input_token:(self # get_token details)
582
fun ~src_name ~mech_type ~output_context
583
~output_token ~ret_flags ~time_rec
584
~delegated_cred ~minor_status ~major_status
586
let (c_err, r_err, flags) = major_status in
587
if c_err <> `None || r_err <> `None then
588
failwith("Rpc_auth_gssapi: Cannot accept token: " ^
589
string_of_major_status major_status);
590
let h = new_handle() in
592
match output_context with
594
failwith "Rpc_auth_gssapi: no context"
596
let cont = List.mem `Continue_needed flags in
602
if shared_context then None else Some conn_id;
603
ctx_svc_none = false;
604
ctx_svc_integrity = false;
605
ctx_svc_privacy = false;
606
ctx_window = ( match seq_number_window with
608
| Some n -> Some(init_window n)
612
self#fixup_svc_flags ctx ret_flags;
613
Hashtbl.replace ctx_by_handle h ctx;
618
then gss_s_continue_needed
621
res_seq_window = ( match seq_number_window with
625
Rtypes.uint4_of_int n
627
res_token = output_token
629
self # auth_init_result ctx reply
634
method private auth_cont_init srv conn_id details cred1 =
635
dlog "auth_cont_init";
636
let (verf_flav, verf_data) = details # verifier in
637
if details#procedure <> Rtypes.uint4_of_int 0 then
638
failwith "For context initialization the RPC procedure must be 0";
639
if verf_flav <> "AUTH_NONE" then
640
failwith "Bad verifier (1)";
641
if verf_data <> "" then
642
failwith "Bad verifier (2)";
643
let h = cred1.handle in
645
try Hashtbl.find ctx_by_handle h
647
failwith "Rpc_auth_gssapi: unknown context handle" in
648
if not ctx.ctx_continue then
649
failwith "Rpc_auth_gssapi: cannot continue context establishment";
650
self # verify_context ctx conn_id;
651
gss_api # accept_sec_context
652
~context:(Some ctx.context)
654
~input_token:(self # get_token details)
657
fun ~src_name ~mech_type ~output_context
658
~output_token ~ret_flags ~time_rec
659
~delegated_cred ~minor_status ~major_status
661
let (c_err, r_err, flags) = major_status in
662
if c_err <> `None || r_err <> `None then
663
failwith("Rpc_auth_gssapi: Cannot accept token: " ^
664
string_of_major_status major_status);
665
(* CHECK: do we need to check whether output_context is
666
the current context? Can this change?
668
ctx.ctx_continue <- List.mem `Continue_needed flags;
669
if not ctx.ctx_continue then
670
self#fixup_svc_flags ctx ret_flags;
675
then gss_s_continue_needed
678
res_seq_window = ( match seq_number_window with
682
Rtypes.uint4_of_int n
684
res_token = output_token
686
self # auth_init_result ctx reply
690
method private auth_init_result ctx reply =
691
dlog "auth_init_result";
693
Rpc_auth_gssapi_aux._of_rpc_gss_init_res reply in
695
Xdr.pack_xdr_value_as_mstrings
696
xdr_val rpc_gss_init_res [] in
697
let (verf_flav, verf_data) =
698
if ctx.ctx_continue then
702
Rtypes.uint4_as_string reply.res_seq_window in
707
~message:[Xdr_mstring.string_to_mstring window_s]
708
~out:(fun ~msg_token ~minor_status ~major_status () ->
709
let (c_err, r_err, flags) = major_status in
710
if c_err <> `None || r_err <> `None then
711
failwith("Rpc_auth_gssapi: \
712
Cannot compute MIC: " ^
713
string_of_major_status major_status);
717
("RPCSEC_GSS", mic) in
718
Rpc_server.Auth_reply(m, verf_flav, verf_data)
720
method private auth_data srv conn_id details cred1 =
723
let h = cred1.handle in
725
try Hashtbl.find ctx_by_handle h
727
failwith "Rpc_auth_gssapi: unknown context handle" in
728
self # verify_context ctx conn_id;
730
(* Verify the header first *)
731
let (verf_flav, verf_data) = details # verifier in
732
if verf_flav <> "RPCSEC_GSS" then
733
failwith "Rpc_auth_gssapi: Bad type of verifier";
734
let pv = details # message in
735
let n = Rpc_packer.extract_call_gssapi_header pv in
736
let s = Rpc_packer.prefix_of_packed_value pv n in
740
~message:[Xdr_mstring.string_to_mstring s]
742
~out:(fun ~qop_state ~minor_status ~major_status () ->
743
let (c_err, r_err, flags) = major_status in
744
if c_err <> `None || r_err <> `None then
745
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_credproblem)
746
(* demanded by the RFC *)
748
failwith("Rpc_auth_gssapi: \
749
Cannot verify MIC: " ^
750
string_of_major_status major_status);
755
(* FIXME: we should also check here whether the credentials'
756
lifetime is over, and if so, report RPCSEC_GSS_ctxproblem.
757
We cannot delay this until encoding/decoding because the
758
exception handling would not work by then. So it must
759
happen now. I have no idea how to do so, though.
762
(* Check sequence number *)
763
if Rtypes.gt_uint4 cred1.seq_num maxseq then
764
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_ctxproblem);
767
match ctx.ctx_window with
770
not (check_seq_num w cred1.seq_num) in
775
match cred1.service with
776
| `rpc_gss_svc_none ->
777
if not ctx.ctx_svc_none then
778
failwith "Rpc_auth_gssapi: unexpected unprotected message";
779
self#auth_data_result ctx cred1.seq_num None None;
781
| `rpc_gss_svc_integrity ->
782
if not ctx.ctx_svc_integrity then
783
failwith "Rpc_auth_gssapi: unexpected integrity-proctected \
787
gss_api ctx.context true cred1 rpc_gss_integ_data in
790
gss_api ctx.context true cred1 rpc_gss_integ_data in
791
self#auth_data_result
792
ctx cred1.seq_num (Some encoder) (Some decoder)
794
| `rpc_gss_svc_privacy ->
795
if not ctx.ctx_svc_privacy then
796
failwith "Rpc_auth_gssapi: unexpected privacy-proctected \
800
gss_api ctx.context true cred1 rpc_gss_priv_data in
802
privacy_decoder gss_api ctx.context true
803
cred1 rpc_gss_priv_data in
804
self # auth_data_result
805
ctx cred1.seq_num (Some encoder) (Some decoder)
808
method private auth_data_result ctx seq enc_opt dec_opt =
809
dlog "auth_data_result";
811
Rtypes.uint4_as_string seq in
816
~message:[Xdr_mstring.string_to_mstring seq_s]
817
~out:(fun ~msg_token ~minor_status ~major_status () ->
818
let (c_err, r_err, flags) = major_status in
819
if c_err <> `None || r_err <> `None then
820
raise(Rpc.Rpc_server Rpc.RPCSEC_GSS_ctxproblem);
822
failwith("Rpc_auth_gssapi: \
823
Cannot compute MIC: " ^
824
string_of_major_status major_status);
829
Rpc_server.Auth_positive(
831
"RPCSEC_GSS", mic, enc_opt, dec_opt
834
method private auth_destroy srv conn_id details cred1 =
836
if details#procedure <> Rtypes.uint4_of_int 0 then
837
failwith "For context destruction the RPC procedure must be 0";
839
self # auth_data srv conn_id details cred1 in
841
| Rpc_server.Auth_positive(_, flav, mic, enc_opt, dec_opt) ->
842
(* Check that the input args are empty: *)
844
Rpc_packer.unpack_call_body_raw
845
details#message details#frame_len in
848
| None -> String.length raw_body
850
let (b,n) = dec raw_body 0 (String.length raw_body) in
852
if body_length <> 0 then
853
failwith "Rpc_auth_gssapi: invalid destroy request";
856
let h = cred1.handle in
857
Hashtbl.remove ctx_by_handle h;
859
(* Create response: *)
860
let encoded_emptiness =
863
| Some enc -> enc [] in
866
Rpc_server.Auth_reply(encoded_emptiness, flav, mic)
873
let client_auth_method
874
?(privacy=`If_possible)
875
?(integrity=`If_possible)
876
?(user_name_interpretation = `Prefixed_name)
877
(gss_api : gss_api) mech : Rpc_client.auth_method =
879
let default_initiator_cred() =
880
gss_api # acquire_cred
881
~desired_name:gss_api#no_name
883
~desired_mechs:[mech]
884
~cred_usage:`Initiate
886
fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status() ->
887
let (c_err, r_err, flags) = major_status in
888
if c_err <> `None || r_err <> `None then
889
failwith("Rpc_auth_gssapi: Cannot acquire default creds: " ^
890
string_of_major_status major_status);
896
Xdr.validate_xdr_type
897
Rpc_auth_gssapi_aux.xdrt_rpc_gss_cred_t in
899
let rpc_gss_integ_data =
900
Xdr.validate_xdr_type
901
Rpc_auth_gssapi_aux.xdrt_rpc_gss_integ_data in
903
let rpc_gss_priv_data =
904
Xdr.validate_xdr_type
905
Rpc_auth_gssapi_aux.xdrt_rpc_gss_priv_data in
907
let session (m:Rpc_client.auth_method)
908
(p:Rpc_client.auth_protocol)
909
ctx service handle cur_seq_num
910
: Rpc_client.auth_session =
911
let seq_num_of_xid = Hashtbl.create 15 in
913
method next_credentials client prog proc xid =
914
(* N.B. Exceptions raised here probably abort the client,
915
and fall through to the event loop
920
sprintf "next_credentials proc=%s xid=%Ld"
921
proc (Rtypes.int64_of_uint4 xid)
925
{ gss_proc = `rpcsec_gss_data;
926
seq_num = !cur_seq_num;
930
let cred1_xdr = _of_rpc_gss_cred_t (`_1 cred1) in
932
Xdr.pack_xdr_value_as_string
933
cred1_xdr rpc_gss_cred_t [] in
936
Rpc_packer.pack_call_gssapi_header
937
prog xid proc "RPCSEC_GSS" cred1_s in
939
Rpc_packer.string_of_packed_value h_pv in
944
~message:[Xdr_mstring.string_to_mstring h]
945
~out:(fun ~msg_token ~minor_status ~major_status () ->
946
let (c_err, r_err, flags) = major_status in
947
if c_err <> `None || r_err <> `None then
948
failwith("Rpc_auth_gssapi: \
949
Cannot obtain MIC: " ^
950
string_of_major_status major_status);
956
Hashtbl.replace seq_num_of_xid xid !cur_seq_num;
958
(* Increment cur_seq_num: *)
960
Rtypes.uint4_of_int64(
962
(Int64.succ (Rtypes.int64_of_uint4 !cur_seq_num))
966
let enc_opt, dec_opt =
968
| `rpc_gss_svc_none ->
971
| `rpc_gss_svc_integrity ->
974
gss_api ctx false cred1 rpc_gss_integ_data in
977
gss_api ctx false cred1 rpc_gss_integ_data in
978
(Some encoder), (Some decoder)
980
| `rpc_gss_svc_privacy ->
982
privacy_encoder gss_api ctx false cred1 rpc_gss_priv_data in
984
privacy_decoder gss_api ctx false cred1 rpc_gss_priv_data in
985
(Some encoder), (Some decoder) in
989
sprintf "next_credentials returns normally"
992
("RPCSEC_GSS", cred1_s,
997
method server_rejects client xid code =
1000
sprintf "server_rejects xid=%Ld"
1001
(Rtypes.int64_of_uint4 xid)
1003
Hashtbl.remove seq_num_of_xid xid;
1005
| Rpc.RPCSEC_GSS_credproblem | Rpc.RPCSEC_GSS_ctxproblem ->
1007
| Rpc.Auth_too_weak ->
1012
method server_accepts client xid verf_flav verf_data =
1015
sprintf "server_accepts xid=%Ld"
1016
(Rtypes.int64_of_uint4 xid)
1018
if verf_flav <> "RPCSEC_GSS" then
1019
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp);
1021
try Hashtbl.find seq_num_of_xid xid
1023
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp) in
1025
Rtypes.uint4_as_string seq in
1026
Hashtbl.remove seq_num_of_xid xid;
1027
gss_api # verify_mic
1029
~message:[Xdr_mstring.string_to_mstring seq_s]
1031
~out:(fun ~qop_state ~minor_status ~major_status () ->
1032
let (c_err, r_err, flags) = major_status in
1033
if c_err <> `None || r_err <> `None then
1034
raise(Rpc.Rpc_server Rpc.Auth_invalid_resp);
1037
dlog "server_accepts returns normally"
1039
method auth_protocol = p
1044
let protocol (m:Rpc_client.auth_method) client cred
1045
: Rpc_client.auth_protocol =
1046
let first = ref true in
1047
let state = ref `Emit in
1048
let ctx = ref None in
1049
let input_token = ref "" in
1050
let handle = ref "" in
1051
let init_prog = ref None in
1052
let init_service = ref None in
1055
match !ctx with Some c -> c | None -> assert false in
1057
(* CHECK: what happens with exceptions thrown here? *)
1060
method state = !state
1062
method emit xid prog_nr vers_nr =
1063
assert(!state = `Emit);
1066
sprintf "emit prog_nr=%Ld vers_nr=%Ld xid=%Ld"
1067
(Rtypes.int64_of_uint4 prog_nr)
1068
(Rtypes.int64_of_uint4 vers_nr)
1069
(Rtypes.int64_of_uint4 xid)
1073
match !init_prog with
1079
(Xdr.validate_xdr_type_system [])
1081
( (Rtypes.uint4_of_int 0),
1082
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_arg,
1083
Rpc_auth_gssapi_aux.xdrt_rpc_gss_init_res
1086
init_prog := Some p;
1090
( if integrity=`If_possible || integrity=`Required then
1095
( if privacy=`If_possible || privacy=`Required then
1100
let (output_token, cont_needed, have_priv, have_integ) =
1101
gss_api # init_sec_context
1102
~initiator_cred:cred
1104
~target_name:gss_api#no_name
1109
~input_token:(if !first then None else Some !input_token)
1110
~out:(fun ~actual_mech_type ~output_context ~output_token
1111
~ret_flags ~time_rec ~minor_status ~major_status
1113
let (c_err, r_err, flags) = major_status in
1114
if c_err <> `None || r_err <> `None then
1115
failwith("Rpc_auth_gssapi: Cannot init sec ctx: " ^
1116
string_of_major_status major_status);
1117
ctx := output_context;
1119
List.mem `Continue_needed flags,
1120
List.mem `Conf_flag ret_flags,
1121
List.mem `Integ_flag ret_flags
1126
match integrity with
1128
if not have_integ && not have_priv then
1129
failwith "Rpc_auth_gssapi: Integrity is not available";
1130
`rpc_gss_svc_integrity
1133
`rpc_gss_svc_integrity
1137
`rpc_gss_svc_none in
1141
if not have_priv then
1142
failwith "Rpc_auth_gssapi: Privacy is not available";
1143
`rpc_gss_svc_privacy
1146
`rpc_gss_svc_privacy
1151
init_service := Some service;
1153
`_1 { gss_proc = ( if !first then `rpcsec_gss_init
1154
else `rpcsec_gss_continue_init );
1155
seq_num = Rtypes.uint4_of_int 0; (* FIXME *)
1159
let cred1_xdr = _of_rpc_gss_cred_t cred1 in
1161
Xdr.pack_xdr_value_as_string
1162
cred1_xdr rpc_gss_cred_t [] in
1164
Rpc_packer.pack_call
1166
"RPCSEC_GSS" cred1_s
1168
(Xdr.XV_struct_fast [| Xdr.XV_opaque output_token |] ) in
1170
state := `Receive xid;
1171
dlog "emit returns normally";
1175
"Rpc_auth_gssapi: Error during message preparation: %s"
1176
(Netexn.to_string error);
1185
match !init_prog with
1186
| None -> assert false
1188
let (xid, flav_name, flav_data, result_xdr) =
1189
Rpc_packer.unpack_reply prog "init" pv in
1190
assert( !state = `Receive xid );
1194
sprintf "receive xid=%Ld"
1195
(Rtypes.int64_of_uint4 xid)
1198
let res = _to_rpc_gss_init_res result_xdr in
1200
res.res_major = gss_s_continue_needed in
1202
if not cont_needed && res.res_major <> gss_s_complete then
1204
(sprintf "Rpc_auth_gssapi: Got GSS-API error code %Ld"
1205
(Rtypes.int64_of_uint4 res.res_major));
1207
if cont_needed then (
1208
if flav_name <> "AUTH_NONE" || flav_data <> "" then
1209
failwith "Rpc_auth_gssapi: bad verifier";
1212
if flav_name <> "RPCSEC_GSS" then
1213
failwith "Rpc_auth_gssapi: bad verifier";
1215
Rtypes.uint4_as_string res.res_seq_window in
1216
gss_api # verify_mic
1217
~context:(get_context())
1218
~message:[Xdr_mstring.string_to_mstring window_s]
1220
~out:(fun ~qop_state ~minor_status ~major_status () ->
1221
let (c_err, r_err, flags) = major_status in
1222
if c_err <> `None || r_err <> `None then
1223
failwith("Rpc_auth_gssapi: \
1224
Cannot verify MIC: " ^
1225
string_of_major_status major_status);
1231
handle := res.res_handle;
1232
input_token := res.res_token;
1237
let c = get_context () in
1239
match !init_service with Some s -> s | None -> assert false in
1240
let cs = ref (Rtypes.uint4_of_int 0) in
1243
m (self :> Rpc_client.auth_protocol) c service !handle cs in
1245
dlog "receive returns normally";
1248
"Rpc_auth_gssapi: Error during message verification: %s"
1249
(Netexn.to_string error);
1253
method auth_method = m
1259
method name = "RPCSEC_GSS"
1261
method new_session client user_opt =
1264
sprintf "new_session user=%s"
1265
(match user_opt with
1266
| None -> "-" | Some u -> u
1273
default_initiator_cred()
1275
let (input_name, input_name_type) =
1276
match user_name_interpretation with
1278
(user, nt_export_name)
1280
let l = String.length user in
1282
let k = String.index user '}' in
1283
let oid = string_to_oid (String.sub user 0 (k+1)) in
1284
let n = String.sub user (k+1) (l-k-1) in
1288
("Rpc_auth_gssapi: cannot parse user name")
1290
| `Plain_name input_name_type ->
1291
(user, input_name_type) in
1293
gss_api # import_name
1296
~out:(fun ~output_name ~minor_status ~major_status
1298
let (c_err, r_err, flags) = major_status in
1299
if c_err <> `None || r_err <> `None then
1301
("Rpc_auth_gssapi: Cannot import name: "
1302
^ string_of_major_status major_status);
1306
gss_api # acquire_cred
1309
~desired_mechs:[mech]
1310
~cred_usage:`Initiate
1312
fun ~cred ~actual_mechs ~time_rec ~minor_status
1315
let (c_err, r_err, flags) = major_status in
1316
if c_err <> `None || r_err <> `None then
1318
("Rpc_auth_gssapi: Cannot acquire default creds: "
1319
^ string_of_major_status major_status);
1323
protocol (self :> Rpc_client.auth_method) client cred
added
removed
src/rpc/rpc_auth_gssapi.ml
