(* $Id$ *)
(* FIXME:
- export_sec_context: the token does not include the sequence numbers,
and it does not include the flags
*)
open Netsys_gssapi
open Netgssapi_support
open Printf
class scram_name (name_string:string) (name_type:oid) =
object
method otype = ( `Name : [`Name] )
method name_string = name_string
method name_type = name_type
end
type cred =
| Cred_server (* there are no server credentials! *)
| Cred_client of string * string (* user name, password *)
| Cred_none
class scram_cred (name:scram_name) (cred:cred) =
object
method otype = ( `Credential : [`Credential] )
method name = name
method cred = cred
end
type ctx =
| Ctx_client of Netmech_scram.client_session
| Ctx_server of Netmech_scram.server_session
class scram_context ctx (init_flags : ret_flag list) =
let valid = ref true in
let server_cb = ref "" in
let specific_keys = ref None in
let seq_nr = ref 0L in
let exp_seq_nr = ref None in
let flags = ref init_flags in
let ctx = ref ctx in
object
method otype = ( `Context : [ `Context ] )
method valid = !valid
method ctx = ctx
method delete() = valid := false
method server_cb = server_cb
method is_acceptor =
match !ctx with
| Ctx_client _ -> false
| Ctx_server _ -> true
method specific_keys =
match !specific_keys with
| Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s)
| None ->
let proto_key_opt =
match !ctx with
| Ctx_client sess ->
Netmech_scram.client_protocol_key sess
| Ctx_server sess ->
Netmech_scram.server_protocol_key sess in
(* The usage numbers are defined in RFC 4121 *)
(match proto_key_opt with
| None -> None
| Some proto_key ->
let k_mic_c =
Netmech_scram.Cryptosystem.derive_keys
proto_key 25 in
let k_mic_s =
Netmech_scram.Cryptosystem.derive_keys
proto_key 23 in
let k_wrap_c =
Netmech_scram.Cryptosystem.derive_keys
proto_key 24 in
let k_wrap_s =
Netmech_scram.Cryptosystem.derive_keys
proto_key 22 in
(*
eprintf "protocol key: %S\n" proto_key;
eprintf "k_mic_c.kc: %S\n" k_mic_c.Netmech_scram.kc;
eprintf "k_mic_s.kc: %S\n" k_mic_s.Netmech_scram.kc;
eprintf "k_wrap_c.ke: %S\n" k_wrap_c.Netmech_scram.ke;
eprintf "k_wrap_c.ki: %S\n" k_wrap_c.Netmech_scram.ki;
eprintf "k_wrap_s.ke: %S\n" k_wrap_s.Netmech_scram.ke;
eprintf "k_wrap_s.ki: %S\n%!" k_wrap_s.Netmech_scram.ki;
*)
specific_keys := Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s);
!specific_keys
)
method seq_nr =
let n = !seq_nr in
seq_nr := Int64.succ !seq_nr;
n
method is_peer_seq_nr_ok n : suppl_status list =
match !exp_seq_nr with
| None ->
exp_seq_nr := Some n;
[]
| Some e ->
if n = e then (
exp_seq_nr := Some (Int64.succ e);
[]
) else (
if n < e then
[ `Unseq_token ]
else
[ `Gap_token ]
)
method flags = flags
end
class type client_key_ring =
object
method password_of_user_name : string -> string
method default_user_name : string option
end
let empty_client_key_ring : client_key_ring =
object
method password_of_user_name _ = raise Not_found
method default_user_name = None
end
class type server_key_verifier =
object
method scram_credentials : string -> Netmech_scram.credentials
end
let empty_server_key_verifier : server_key_verifier =
object
method scram_credentials _ = raise Not_found
end
let scram_mech = [| 1; 3; 6; 1; 5; 5; 14 |]
(*
let as_string (sm,pos,len) =
match sm with
| `String s ->
if pos=0 && len=String.length s then
s
else
String.sub s pos len
| `Memory m ->
let s = String.create len in
Netsys_mem.blit_memory_to_string m pos s 0 len;
s
*)
(*
let empty_msg = (`String "",0,0)
*)
exception Calling_error of calling_error
exception Routine_error of routine_error
module type PROFILE =
sig
val client_key_ring : client_key_ring
val server_key_verifier : server_key_verifier
val scram_profile : Netmech_scram.profile
end
module Make(P:PROFILE) : Netsys_gssapi.GSSAPI = struct
type credential = scram_cred
type context = scram_context
type name = scram_name
exception Credential of credential
exception Context of context
exception Name of name
class type gss_api =
[credential, name, context] Netsys_gssapi.poly_gss_api
let scram_ret_flags =
[ `Mutual_flag; `Conf_flag; `Integ_flag; `Replay_flag; `Sequence_flag ]
let no_cred =
( object
method otype = `Credential
method name = assert false
method cred = Cred_none
end
)
let no_name =
( object
method otype = `Name
method name_type = [| |]
method name_string = ""
end
)
let interface =
object(self)
method provider = "Netmech_scram_gssapi.scram_gss_api"
method no_credential = no_cred
method no_name = no_name
method is_no_credential cred = cred#cred = Cred_none
method is_no_name name = name#name_type = [| |]
method accept_sec_context :
't . context:context option ->
acceptor_cred:credential ->
input_token:token ->
chan_bindings:channel_bindings option ->
out:( src_name:name ->
mech_type:oid ->
output_context:context option ->
output_token:token ->
ret_flags:ret_flag list ->
time_rec:time ->
delegated_cred:credential ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~acceptor_cred ~input_token ~chan_bindings ~out () ->
let acc_name =
new scram_name "@" nt_hostbased_service in
let src_name = acc_name in
try
let cb_data =
match chan_bindings with
| None -> ""
| Some (init_addr, acc_addr, cb_data) -> cb_data in
(* We ignore init_addr and acc_addr... CHECK *)
if acceptor_cred <> no_cred && acceptor_cred#cred <> Cred_server
then
raise(Routine_error `No_cred);
let context, sess, is_first =
match context with
| None ->
let sess =
Netmech_scram.create_server_session
P.scram_profile
P.server_key_verifier#scram_credentials in
let ctx =
Ctx_server sess in
let context = new scram_context ctx scram_ret_flags in
(context # server_cb) := cb_data;
(context, sess, true)
| Some context ->
if not context#valid then
raise (Routine_error `No_context);
let sess =
match !(context#ctx) with
| Ctx_server sess -> sess
| Ctx_client _ -> raise (Routine_error `No_context) in
(context, sess, false) in
let eff_input_token =
if is_first then (* There is a header *)
try
let k = ref 0 in
let (oid, tok) =
Netgssapi_support.wire_decode_token input_token k in
if !k <> String.length input_token then
raise(Routine_error `Defective_token);
if oid <> scram_mech then
raise(Routine_error `Bad_mech);
tok
with
| Failure _ ->
raise(Routine_error `Defective_token);
else
input_token in
(* The following call usually does not raise exceptions. Error codes
are stored inside sess
*)
let sess = Netmech_scram.server_recv_message sess eff_input_token in
let output_context =
Some context in
let sess, output_token =
Netmech_scram.server_emit_message sess in
context # ctx := Ctx_server sess;
if Netmech_scram.server_error_flag sess then (
out
~src_name ~mech_type:scram_mech ~output_context
~output_token
~ret_flags:scram_ret_flags ~time_rec:`Indefinite
~delegated_cred:no_cred
~minor_status:0l ~major_status:(`None,`Failure,[]) ()
)
else
if Netmech_scram.server_finish_flag sess then (
(* Finally check channel bindings: *)
let scram_cb =
match Netmech_scram.server_channel_binding sess with
| `GSSAPI d -> d
| _ -> assert false in
if scram_cb <> !(context # server_cb) then
raise(Routine_error `Bad_bindings);
let ret_flags =
[`Prot_ready_flag; `Trans_flag] @ scram_ret_flags in
context # flags := ret_flags;
out
~src_name ~mech_type:scram_mech ~output_context
~output_token
~ret_flags
~time_rec:`Indefinite
~delegated_cred:no_cred
~minor_status:0l ~major_status:(`None,`None,[]) ()
)
else (
out
~src_name ~mech_type:scram_mech ~output_context
~output_token
~ret_flags:scram_ret_flags ~time_rec:`Indefinite
~delegated_cred:no_cred
~minor_status:0l
~major_status:(`None,`None,[`Continue_needed])
()
)
with
| Calling_error code ->
out
~src_name ~mech_type:scram_mech ~output_context:None
~output_token:""
~ret_flags:scram_ret_flags ~time_rec:`Indefinite
~delegated_cred:no_cred
~minor_status:0l ~major_status:(code,`None,[]) ()
| Routine_error code ->
out
~src_name ~mech_type:scram_mech ~output_context:None
~output_token:""
~ret_flags:scram_ret_flags ~time_rec:`Indefinite
~delegated_cred:no_cred
~minor_status:0l ~major_status:(`None,code,[]) ()
method private get_client_cred user = (* or Not_found *)
let pw = P.client_key_ring # password_of_user_name user in
let name =
new scram_name user nt_user_name in
let cred =
new scram_cred (name:>name) (Cred_client(user,pw)) in
cred
method private get_default_client_cred() = (* or Not_found *)
match P.client_key_ring # default_user_name with
| None -> raise Not_found
| Some user -> self # get_client_cred user
method acquire_cred :
't . desired_name:name ->
time_req:time ->
desired_mechs:oid_set ->
cred_usage:cred_usage ->
out:( cred:credential ->
actual_mechs:oid_set ->
time_rec:time ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~desired_name ~time_req ~desired_mechs ~cred_usage ~out () ->
let error code =
out
~cred:no_cred ~actual_mechs:[] ~time_rec:`Indefinite
~minor_status:0l ~major_status:(`None,code,[]) () in
match cred_usage with
| `Initiate ->
(* For clients *)
if List.mem scram_mech desired_mechs then (
let out_client_cred user =
try
let cred = self#get_client_cred user in
out
~cred:(cred :> credential)
~actual_mechs:[ scram_mech ]
~time_rec:`Indefinite
~minor_status:0l
~major_status:(`None,`None,[])
()
with
| Not_found -> error `No_cred in
(* Expect nt_user_name: *)
if desired_name # name_type = Netsys_gssapi.nt_user_name
then (
let user = desired_name # name_string in
out_client_cred user
)
else (
if desired_name = no_name then (
(* maybe we have a default: *)
match P.client_key_ring # default_user_name with
| None -> error `No_cred
| Some user -> out_client_cred user
)
else
error `Bad_nametype
)
)
else
error `Bad_mech
| `Accept ->
(* For server: Effectively there are no credentials. So we
accept any desired_name.
*)
if List.mem scram_mech desired_mechs then (
let server_name =
new scram_name "@" nt_hostbased_service in
let cred =
new scram_cred (server_name :> name) Cred_server in
out
~cred:(cred :> credential)
~actual_mechs:[ scram_mech ]
~time_rec:`Indefinite
~minor_status:0l
~major_status:(`None,`None,[])
()
)
else
error `Bad_mech
| `Both ->
(* Not supported - credentials are either for the client or
for the server
*)
out
~cred:no_cred ~actual_mechs:[] ~time_rec:`Indefinite
~minor_status:0l ~major_status:(`None,`Bad_nametype,[]) ()
method add_cred :
't . input_cred:credential ->
desired_name:name ->
desired_mech:oid ->
cred_usage:cred_usage ->
initiator_time_req:time ->
acceptor_time_req:time ->
out:( output_cred:credential ->
actual_mechs:oid_set ->
initiator_time_rec:time ->
acceptor_time_rec:time ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~input_cred ~desired_name ~desired_mech ~cred_usage
~initiator_time_req ~acceptor_time_req ~out () ->
(* More or less it is not possible to add to credentials - we have
here only one mechanism. So, the only thing to do here is to
create the right error message.
*)
let error code =
out
~output_cred:no_cred ~actual_mechs:[]
~initiator_time_rec:`Indefinite ~acceptor_time_rec:`Indefinite
~minor_status:0l ~major_status:(`None,code,[]) () in
let add cred =
if scram_mech = desired_mech then
error `Duplicate_element
else
error `Bad_mech in
if input_cred = no_cred then (
self # acquire_cred
~desired_name:(desired_name :> name)
~time_req:`Indefinite ~desired_mechs:[desired_mech] ~cred_usage
~out:(
fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status
() ->
let (_,code,_) = major_status in
if code = `None then add cred else error code
)
()
) else
add input_cred
method canonicalize_name :
't . input_name:name ->
mech_type:oid ->
out:( output_name:name ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~input_name ~mech_type ~out () ->
let error code =
out
~output_name:no_name ~minor_status:0l
~major_status:(`None,code,[]) ()
in
if mech_type <> scram_mech then
error `Bad_mech
else
out
~output_name:(input_name :> name) ~minor_status:0l
~major_status:(`None,`None,[]) ()
method compare_name :
't . name1:name ->
name2:name ->
out:( name_equal:bool ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~name1 ~name2 ~out () ->
let equal =
name1 # name_type <> nt_anonymous &&
name2 # name_type <> nt_anonymous &&
(name1 = name2 ||
(name1#name_type = name2#name_type &&
name1#name_string = name2#name_string)) in
out ~name_equal:equal ~minor_status:0l
~major_status:(`None,`None,[]) ()
method context_time :
't . context:context ->
out:( time_rec:[ `Indefinite | `This of float] ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~out () ->
if not context#valid then
out ~time_rec:`Indefinite ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else
out
~time_rec:`Indefinite ~minor_status:0l
~major_status:(`None,`None,[])
()
method delete_sec_context :
't . context:context ->
out:( minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~out () ->
context#delete();
out ~minor_status:0l ~major_status:(`None,`None,[]) ()
method display_name :
't . input_name:name ->
out:( output_name:string ->
output_name_type:oid ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~input_name ~out () ->
(* We just return the name_string *)
out
~output_name:input_name#name_string
~output_name_type:input_name#name_type
~minor_status:0l
~major_status:(`None,`None,[])
()
method display_minor_status :
't . status_value:minor_status ->
mech_type: oid ->
out:( status_strings: string list ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~status_value ~mech_type ~out () ->
out
~status_strings:["<minor>"]
~minor_status:0l ~major_status:(`None,`None,[]) ()
method export_name :
't . name:name ->
out:( exported_name:string ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~name ~out () ->
let s1 =
encode_exported_name name#name_type name#name_string in
let s2 =
encode_exported_name scram_mech s1 in
out
~exported_name:s2
~minor_status:0l
~major_status:(`None,`None,[])
()
method export_sec_context :
't . context:context ->
out:( interprocess_token:interprocess_token ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~out () ->
(* FIXME: Maybe we should also export the seq_nr *)
if not context#valid then
out
~interprocess_token:"" ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else (
try
let interprocess_token =
match !(context#ctx) with
| Ctx_client sess ->
"C" ^ Netmech_scram.client_export sess
| Ctx_server sess ->
"S" ^ Netmech_scram.server_export sess in
out
~interprocess_token ~minor_status:0l
~major_status:(`None,`None,[]) ()
with
| Failure _ ->
out
~interprocess_token:"" ~minor_status:0l
~major_status:(`None,`Unavailable,[]) ()
)
method get_mic :
't . context:context ->
qop_req:qop ->
message:message ->
out:( msg_token:token ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~qop_req ~message ~out () ->
if not context#valid then
out
~msg_token:"" ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else (
(* Reject any QOP: *)
if qop_req <> 0l then
out
~msg_token:"" ~minor_status:0l
~major_status:(`None,`Bad_QOP,[]) ()
else (
let sk_opt = context # specific_keys in
match sk_opt with
| None ->
out
~msg_token:"" ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
| Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
let sk_mic =
if context#is_acceptor then k_mic_s else k_mic_c in
let sequence_number = context # seq_nr in
let sent_by_acceptor = context # is_acceptor in
let token =
Netgssapi_support.create_mic_token
~sent_by_acceptor
~acceptor_subkey:false
~sequence_number
~get_mic:(
Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic)
~message in
out
~msg_token:token ~minor_status:0l
~major_status:(`None,`None,[])
()
)
)
method import_name :
't . input_name:string ->
input_name_type:oid ->
out:( output_name:name ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~input_name ~input_name_type ~out () ->
let out_name name_string name_type =
let n = new scram_name name_string name_type in
out
~output_name:(n :> name)
~minor_status:0l
~major_status:(`None,`None,[])
() in
if input_name_type = nt_hostbased_service then
try
let (_service,_host) = parse_hostbased_service input_name in
out_name input_name nt_hostbased_service
with
| _ ->
out
~output_name:no_name ~minor_status:0l
~major_status:(`None,`Bad_name,[]) ()
else
if input_name_type = nt_user_name then
out_name input_name nt_user_name
else
if input_name_type = nt_export_name then
try
let k = ref 0 in
let (mech_oid,s1) = decode_exported_name input_name k in
if !k <> String.length input_name then failwith "too short";
if mech_oid <> scram_mech then
out
~output_name:no_name ~minor_status:0l
~major_status:(`None,`Bad_name,[]) ()
else (
k := 0;
let (name_oid,s2) = decode_exported_name s1 k in
if !k <> String.length input_name then failwith "too short";
out_name s2 name_oid
)
with
| Failure _ ->
out
~output_name:no_name ~minor_status:0l
~major_status:(`None,`Bad_name,[]) ()
else
if input_name_type = [||] then
out_name input_name nt_user_name
else
out
~output_name:no_name
~minor_status:0l
~major_status:(`None,`Bad_nametype,[])
()
method import_sec_context :
't . interprocess_token:interprocess_token ->
out:( context:context option ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~interprocess_token ~out () ->
let error code =
out ~context:None ~minor_status:0l
~major_status:(`None,code,[]) () in
let l = String.length interprocess_token in
if interprocess_token = "" then
error `Defective_token
else
match interprocess_token.[0] with
| 'C' ->
let t = String.sub interprocess_token 1 (l-1) in
let sess =
Netmech_scram.client_import t in
let context =
new scram_context (Ctx_client sess) scram_ret_flags in
out
~context:(Some (context :> context))
~minor_status:0l ~major_status:(`None,`None,[]) ()
| 'S' ->
let t = String.sub interprocess_token 1 (l-1) in
let sess =
Netmech_scram.server_import t in
let context =
new scram_context (Ctx_server sess) scram_ret_flags in
out
~context:(Some (context :> context))
~minor_status:0l ~major_status:(`None,`None,[]) ()
| _ ->
error `Defective_token
method indicate_mechs :
't . out:( mech_set:oid_set ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~out () ->
out
~mech_set:[ scram_mech ]
~minor_status:0l
~major_status:(`None, `None, [])
()
method init_sec_context :
't . initiator_cred:credential ->
context:context option ->
target_name:name ->
mech_type:oid ->
req_flags:req_flag list ->
time_req:float option ->
chan_bindings:channel_bindings option ->
input_token:token option ->
out:( actual_mech_type:oid ->
output_context:context option ->
output_token:token ->
ret_flags:ret_flag list ->
time_rec:[ `Indefinite | `This of float ] ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun
~initiator_cred ~context ~target_name ~mech_type ~req_flags
~time_req ~chan_bindings ~input_token ~out () ->
let actual_mech_type = scram_mech in
try
let cb_data =
match chan_bindings with
| None -> ""
| Some (init_addr, acc_addr, cb_data) -> cb_data in
(* We ignore init_addr and acc_addr... CHECK *)
let eff_init_cred =
if initiator_cred = no_cred then
try self # get_default_client_cred()
with
| Not_found ->
raise(Routine_error `No_cred); (* No default *)
else
initiator_cred in
let user, pw =
match eff_init_cred # cred with
| Cred_client(user,pw) -> (user,pw)
| _ ->
raise(Routine_error `No_cred) in
let context, sess, continuation =
match context with
| None ->
let sess =
Netmech_scram.create_client_session
P.scram_profile user pw in
let ctx =
Ctx_client sess in
let context = new scram_context ctx scram_ret_flags in
ignore(Netmech_scram.client_configure_channel_binding
sess (`GSSAPI cb_data));
(context, sess, false)
| Some context ->
if not context#valid then
raise(Routine_error `No_context);
let sess =
match !(context#ctx) with
| Ctx_client sess -> sess
| Ctx_server _ -> raise (Routine_error `No_context) in
(context, sess, true) in
if mech_type <> [||] && mech_type <> scram_mech then
raise(Routine_error `Bad_mech);
(* Note that we ignore target_name entirely. It is not needed for
SCRAM.
*)
let sess =
if continuation then ( (* this may raise exceptions *)
try
match input_token with
| Some intok ->
Netmech_scram.client_recv_message sess intok
| None ->
raise(Calling_error `Bad_structure)
with
| Netmech_scram.Invalid_encoding(_,_) ->
raise(Routine_error `Defective_token)
| Netmech_scram.Invalid_username_encoding(_,_) ->
raise(Routine_error `Defective_token)
| Netmech_scram.Extensions_not_supported(_,_) ->
raise(Routine_error `Failure)
| Netmech_scram.Protocol_error _ ->
raise(Routine_error `Failure)
| Netmech_scram.Invalid_server_signature ->
raise(Routine_error `Bad_mic)
| Netmech_scram.Server_error e ->
( match e with
| `Invalid_encoding
| `Extensions_not_supported
| `Invalid_proof
| `Channel_bindings_dont_match
| `Server_does_support_channel_binding
| `Channel_binding_not_supported
| `Unsupported_channel_binding_type
| `Unknown_user
| `Invalid_username_encoding
| `No_resources
| `Other_error
| `Extension _ ->
raise(Routine_error `Failure)
)
) else sess in
if Netmech_scram.client_finish_flag sess then (
context # ctx := Ctx_client sess;
let ret_flags =
[`Trans_flag; `Prot_ready_flag ] @ scram_ret_flags in
context # flags := ret_flags;
out
~actual_mech_type ~output_context:(Some (context :> context))
~output_token:""
~ret_flags
~time_rec:`Indefinite ~minor_status:0l
~major_status:(`None,`None,[]) ()
)
else (
let sess, output_token_1 =
Netmech_scram.client_emit_message sess in
context # ctx := Ctx_client sess;
let output_token =
if continuation then
output_token_1
else
Netgssapi_support.wire_encode_token scram_mech
output_token_1 in
let ret_flags =
if Netmech_scram.client_protocol_key sess <> None then
`Prot_ready_flag :: scram_ret_flags
else
scram_ret_flags in
context # flags := ret_flags;
out
~actual_mech_type ~output_context:(Some (context :> context))
~output_token ~ret_flags
~time_rec:`Indefinite ~minor_status:0l
~major_status:(`None,`None,[`Continue_needed]) ()
)
with
| Calling_error code ->
out
~actual_mech_type ~output_context:None
~output_token:"" ~ret_flags:scram_ret_flags
~time_rec:`Indefinite ~minor_status:0l
~major_status:(code,`None,[]) ()
| Routine_error code ->
out
~actual_mech_type ~output_context:None
~output_token:"" ~ret_flags:scram_ret_flags
~time_rec:`Indefinite ~minor_status:0l
~major_status:(`None,code,[]) ()
method inquire_context :
't . context:context ->
out:( src_name:name ->
targ_name:name ->
lifetime_req : time ->
mech_type:oid ->
ctx_flags:ret_flag list ->
locally_initiated:bool ->
is_open:bool ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~out () ->
let error code =
out
~src_name:no_name ~targ_name:no_name
~lifetime_req:`Indefinite
~mech_type:scram_mech ~ctx_flags:scram_ret_flags
~locally_initiated:false ~is_open:false
~minor_status:0l ~major_status:(`None, code, []) () in
if context # valid then
match !(context # ctx) with
| Ctx_client sess ->
let src_name =
new scram_name
(Netmech_scram.client_user_name sess) nt_user_name in
let src_name = (src_name :> name) in
let targ_name =
new scram_name "@" nt_hostbased_service in
let targ_name = (targ_name :> name) in
let is_open = Netmech_scram.client_finish_flag sess in
out
~src_name ~targ_name ~lifetime_req:`Indefinite
~mech_type:scram_mech ~ctx_flags:!(context # flags)
~locally_initiated:true ~is_open
~minor_status:0l ~major_status:(`None, `None, []) ()
| Ctx_server sess ->
let src_name =
match Netmech_scram.server_user_name sess with
| None ->
no_name
| Some u ->
new scram_name u nt_user_name in
let src_name = (src_name :> name) in
let targ_name =
new scram_name "@" nt_hostbased_service in
let targ_name = (targ_name :> name) in
let is_open = Netmech_scram.server_finish_flag sess in
out
~src_name ~targ_name ~lifetime_req:`Indefinite
~mech_type:scram_mech ~ctx_flags:!(context # flags)
~locally_initiated:true ~is_open
~minor_status:0l ~major_status:(`None, `None, []) ()
else
error `No_context
method inquire_cred :
't . cred:credential ->
out:( name:name ->
lifetime: [ `Indefinite | `This of float ] ->
cred_usage:cred_usage ->
mechanisms:oid_set ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~cred ~out () ->
let eff_cred =
if cred = no_cred then
try
self # get_default_client_cred()
with
| Not_found -> no_cred
(* We do not support a default initiator credential *)
else
cred in
if eff_cred = no_cred then
out
~name:no_name
~lifetime:`Indefinite
~cred_usage:`Initiate
~mechanisms:[]
~minor_status:0l
~major_status:(`None, `No_cred, [])
()
else
out
~name:eff_cred#name
~lifetime:`Indefinite
~cred_usage:( match eff_cred#cred with
| Cred_server -> `Accept
| Cred_client _ -> `Initiate
| _ -> assert false
)
~mechanisms:[ scram_mech ]
~minor_status:0l
~major_status:(`None, `None, [])
()
method inquire_cred_by_mech :
't . cred:credential ->
mech_type:oid ->
out:( name:name ->
initiator_lifetime: [ `Indefinite | `This of float ] ->
acceptor_lifetime: [ `Indefinite | `This of float ] ->
cred_usage:cred_usage ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~cred ~mech_type ~out () ->
let error code =
out
~name:no_name ~initiator_lifetime:`Indefinite
~acceptor_lifetime:`Indefinite ~cred_usage:`Initiate
~minor_status:0l ~major_status:(`None,code,[]) () in
if mech_type <> scram_mech then
error `Bad_mech
(* CHECK: not documented in RFC 2744 for this function *)
else
let eff_cred_opt =
if cred = no_cred then
try Some(self # get_default_client_cred())
with Not_found -> None
else
Some cred in
match eff_cred_opt with
| Some eff_cred ->
out
~name:eff_cred#name
~initiator_lifetime:`Indefinite
~acceptor_lifetime:`Indefinite
~cred_usage:( match eff_cred#cred with
| Cred_server -> `Accept
| Cred_client _ -> `Initiate
| _ -> assert false
)
~minor_status:0l
~major_status:(`None, `None, [])
()
| None ->
error `No_cred (* No default initiator credentials *)
method inquire_mechs_for_name :
't . name:name ->
out:( mech_types:oid_set ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~name ~out () ->
let l =
if name#name_type = nt_hostbased_service ||
name#name_type = nt_user_name
then
[ scram_mech ]
else
[] in
out
~mech_types:l ~minor_status:0l ~major_status:(`None,`None,[]) ()
method inquire_names_for_mech :
't . mechanism:oid ->
out:( name_types:oid_set ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~mechanism ~out () ->
let l =
if mechanism = scram_mech then
[ nt_hostbased_service; nt_user_name ]
else
[] in
out
~name_types:l
~minor_status:0l
~major_status:(`None, `None, [])
()
method process_context_token :
't . context:context ->
token:token ->
out:( minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~token ~out () ->
(* There are no context tokens... *)
out ~minor_status:0l ~major_status:(`None,`Defective_token,[]) ()
method unwrap :
't . context:context ->
input_message:message ->
output_message_preferred_type:[ `Bytes | `Memory ] ->
out:( output_message:message ->
conf_state:bool ->
qop_state:qop ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~input_message ~output_message_preferred_type ~out
() ->
let sk_opt = context # specific_keys in
let error code =
out
~output_message:[] ~conf_state:false ~qop_state:0l
~minor_status:0l ~major_status:(`None,code,[]) () in
if not context#valid then
error `No_context
else
match sk_opt with
| None ->
error `No_context
| Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
let sk_wrap =
if context#is_acceptor then k_wrap_c else k_wrap_s in
( try
let (sent_by_acceptor, _, _, tok_seq_nr) =
Netgssapi_support.parse_wrap_token_header
input_message in
if sent_by_acceptor = context#is_acceptor then
raise Netmech_scram.Cryptosystem.Integrity_error;
let flags = context#is_peer_seq_nr_ok tok_seq_nr in
let s =
Netgssapi_support.unwrap_wrap_token_conf
~decrypt_and_verify:(
Netmech_scram.Cryptosystem.decrypt_and_verify_mstrings
sk_wrap)
~token:input_message in
out
~output_message:s
~conf_state:true
~qop_state:0l
~minor_status:0l ~major_status:(`None,`None,flags) ()
with
| Netmech_scram.Cryptosystem.Integrity_error ->
error `Bad_mic
| _ -> (* probable Invalid_argument *)
error `Defective_token
)
method verify_mic :
't . context:context ->
message:message ->
token:token ->
out:( qop_state:qop ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~message ~token ~out () ->
let sk_opt = context # specific_keys in
if not context#valid then
out
~qop_state:0l ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else
match sk_opt with
| None ->
out
~qop_state:0l ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
| Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
let sk_mic =
if context#is_acceptor then k_mic_c else k_mic_s in
let (sent_by_acceptor,_,tok_seq_nr) =
Netgssapi_support.parse_mic_token_header token in
let flags =
context#is_peer_seq_nr_ok tok_seq_nr in
let ok =
sent_by_acceptor <> context#is_acceptor &&
(Netgssapi_support.verify_mic_token
~get_mic:(Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic)
~message
~token) in
if ok then
out
~qop_state:0l ~minor_status:0l
~major_status:(`None,`None,flags) ()
else
out
~qop_state:0l ~minor_status:0l
~major_status:(`None,`Bad_mic,[]) ()
method wrap :
't . context:context ->
conf_req:bool ->
qop_req:qop ->
input_message:message ->
output_message_preferred_type:[ `Bytes | `Memory ] ->
out:( conf_state:bool ->
output_message:message ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun
~context ~conf_req ~qop_req ~input_message
~output_message_preferred_type ~out () ->
if not context#valid then
out
~conf_state:false ~output_message:[] ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else
let sk_opt = context # specific_keys in
(* Reject any QOP: *)
if qop_req <> 0l then
out
~conf_state:false ~output_message:[] ~minor_status:0l
~major_status:(`None,`Bad_QOP,[]) ()
else (
match sk_opt with
| None ->
out
~conf_state:false ~output_message:[] ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
| Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
let sk_wrap =
if context#is_acceptor then k_wrap_s else k_wrap_c in
let token =
Netgssapi_support.create_wrap_token_conf
~sent_by_acceptor:context#is_acceptor
~acceptor_subkey:false
~sequence_number:context#seq_nr
~get_ec:(
Netmech_scram.Cryptosystem.get_ec sk_wrap)
~encrypt_and_sign:(
Netmech_scram.Cryptosystem.encrypt_and_sign_mstrings
sk_wrap)
~message:input_message in
out
~conf_state:true
~output_message:token
~minor_status:0l
~major_status:(`None,`None,[])
()
)
method wrap_size_limit :
't . context:context ->
conf_req:bool ->
qop_req:qop ->
req_output_size:int ->
out:( max_input_size:int ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~conf_req ~qop_req ~req_output_size ~out () ->
(* We have:
- 12 bytes for the MIC
- the message is padded to a multiple of 16 bytes
- the message includes a 16 bytes random header
*)
let p_size = (req_output_size - 12) / 16 * 16 in
let m_size = max 0 (p_size - 16) in
out
~max_input_size:m_size ~minor_status:0l ~major_status:(`None,`None,[])
()
method duplicate_name :
't . name:'name ->
out:( dest_name:'name ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~name ~out () ->
let dest_name = new scram_name name#name_string name#name_type in
out ~dest_name ~minor_status:0l ~major_status:(`None,`None,[]) ()
end
end
let scram_gss_api ?(client_key_ring = empty_client_key_ring)
?(server_key_verifier = empty_server_key_verifier)
profile =
let module P =
struct
let client_key_ring = client_key_ring
let server_key_verifier = server_key_verifier
let scram_profile = profile
end in
let module G = Make(P) in
(module G : Netsys_gssapi.GSSAPI)
