(* $Id: netmech_scram_gssapi.ml 1562 2011-03-07 16:13:14Z gerd $ *)
(* FIXME:
- export_sec_context: the token does not include the sequence numbers,
and it does not include the flags
*)
open Netgssapi
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: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
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
module type BACK_COERCE_OBJECT = sig
type t
val hide : t -> < >
val exhibit : < > -> t
end
module Back_coerce_table(T:BACK_COERCE_OBJECT) : sig
type table
val create : unit -> table
val store : table -> T.t -> unit
val retrieve : table -> < > -> T.t
end = struct
module E = struct
type t = < >
let equal x y = x = y
let hash x = Hashtbl.hash x
end
module W = Weak.Make(E)
type table = W.t
let create() =
W.create 10
let store table (x : T.t) =
ignore(W.merge table (T.hide x))
let retrieve table (x : < >) : T.t =
if W.mem table x then
T.exhibit x
else
invalid_arg "Netmech_scram_gssapi: Unknown opaque object"
end
module Credential = struct
type t = scram_cred
let hide x = (x :> < >)
let exhibit x = (Obj.magic x : t)
end
module CredentialBCT = Back_coerce_table(Credential)
module Name = struct
type t = scram_name
let hide x = (x :> < >)
let exhibit x = (Obj.magic x : t)
end
module NameBCT = Back_coerce_table(Name)
module Context = struct
type t = scram_context
let hide x = (x :> < > )
let exhibit x = (Obj.magic x : t)
end
module ContextBCT = Back_coerce_table(Context)
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 -> string * string * int
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
class scram_gss_api ?(client_key_ring = empty_client_key_ring)
?(server_key_verifier = empty_server_key_verifier)
profile
: gss_api =
let scram_ret_flags =
[ `Mutual_flag; `Conf_flag; `Integ_flag; `Replay_flag; `Sequence_flag ] in
let credentials = CredentialBCT.create() in
let names = NameBCT.create() in
let contexts = ContextBCT.create() in
let cred_retrieve obj =
CredentialBCT.retrieve credentials (obj : credential :> < >) in
let name_retrieve obj =
NameBCT.retrieve names (obj : name :> < >) in
let context_retrieve obj =
ContextBCT.retrieve contexts (obj : context :> < >) in
let no_cred =
( object
method otype = `Credential
method name = assert false
method cred = Cred_none
end
) in
let no_cred_out = (no_cred :> credential) in
let () = CredentialBCT.store credentials no_cred in
let no_name =
( object
method otype = `Name
method name_type = [| |]
method name_string = ""
end
) in
let no_name_out = (no_name :> name) in
let () = NameBCT.store names no_name in
let default_qop =
( object method otype = `QOP end ) in (* just return something *)
object(self)
method provider = "Netmech_scram_gssapi.scap_gss_api"
method no_credential = (no_cred :> credential)
method no_name = (no_name :> name)
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:[ `Indefinite | `This of float] ->
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
NameBCT.store names acc_name;
let src_name = (acc_name :> 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 *)
let acceptor_cred =
cred_retrieve acceptor_cred in
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
profile
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;
ContextBCT.store contexts context;
(context, sess, true)
| Some c ->
let context = context_retrieve c in
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.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
*)
Netmech_scram.server_recv_message sess eff_input_token;
let output_context =
Some (context :> context) in
let output_token =
Netmech_scram.server_emit_message sess in
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_out
~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
| None -> assert false
| Some d -> d 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_out
~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_out
~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_out
~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_out
~minor_status:0l ~major_status:(`None,code,[]) ()
method private get_client_cred user = (* or Not_found *)
let pw = client_key_ring # password_of_user_name user in
let name =
new scram_name user nt_user_name in
NameBCT.store names name;
let cred =
new scram_cred (name:>name) (Cred_client(user,pw)) in
CredentialBCT.store credentials cred;
cred
method private get_default_client_cred() = (* or Not_found *)
match 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:[`None | `Indefinite | `This of float] ->
desired_mechs:oid_set ->
cred_usage:cred_usage ->
out:( cred:credential ->
actual_mechs:oid_set ->
time_rec:[ `Indefinite | `This of float] ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~desired_name ~time_req ~desired_mechs ~cred_usage ~out () ->
let desired_name = name_retrieve desired_name in
let error code =
out
~cred:no_cred_out ~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 = Netgssapi.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 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
NameBCT.store names server_name;
let cred =
new scram_cred (server_name :> name) Cred_server in
CredentialBCT.store credentials cred;
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_out ~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:[`None | `Indefinite | `This of float] ->
acceptor_time_req:[`None | `Indefinite | `This of float] ->
out:( output_cred:credential ->
actual_mechs:oid_set ->
initiator_time_rec:[ `Indefinite | `This of float] ->
acceptor_time_rec:[ `Indefinite | `This of float] ->
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_out ~actual_mechs:[]
~initiator_time_rec:`Indefinite ~acceptor_time_rec:`Indefinite
~minor_status:0l ~major_status:(`None,code,[]) () in
let input_cred = cred_retrieve input_cred in
let desired_name = name_retrieve desired_name 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:`None ~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_out ~minor_status:0l
~major_status:(`None,code,[]) ()
in
let input_name = name_retrieve input_name 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 name1 = name_retrieve name1 in
let name2 = name_retrieve name2 in
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 () ->
let context = context_retrieve context in
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 () ->
let context = context_retrieve context in
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 *)
let input_name = name_retrieve input_name in
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 . minor_status:minor_status ->
mech_type: oid ->
out:( status_strings: string list ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~minor_status ~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 name = name_retrieve name in
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 *)
let context = context_retrieve context in
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 option ->
message:message ->
out:( msg_token:token ->
minor_status:minor_status ->
major_status:major_status ->
unit ->
't
) -> unit -> 't =
fun ~context ~qop_req ~message ~out () ->
let context = context_retrieve context in
if not context#valid then
out
~msg_token:"" ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else (
(* Reject any QOP: *)
if qop_req <> None && qop_req <> Some default_qop 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.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
NameBCT.store names n;
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_out ~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_out ~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_out ~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_out
~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
ContextBCT.store contexts context;
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
ContextBCT.store contexts context;
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_rec: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_rec ~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 initiator_cred =
cred_retrieve initiator_cred in
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
profile user pw in
let ctx =
Ctx_client sess in
let context = new scram_context ctx scram_ret_flags in
(context # server_cb) := cb_data;
ContextBCT.store contexts context;
(context, sess, false)
| Some c ->
let context = context_retrieve c in
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);
(*
if List.mem `Deleg_flag req_flags then XXX;
if List.mem `Anon_flag req_flags then XXX;
*)
(* Note that we ignore target_name entirely. It is not needed for
SCRAM.
*)
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)
)
);
if Netmech_scram.client_finish_flag sess then (
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 output_token_1 =
Netmech_scram.client_emit_message sess in
let output_token =
if continuation then
output_token_1
else
Netgssapi.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 : [ `Indefinite | `This of float ] ->
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_out ~targ_name:no_name_out ~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
let context = context_retrieve context 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
NameBCT.store names src_name;
let src_name = (src_name :> name) in
let targ_name =
new scram_name "@" nt_hostbased_service in
NameBCT.store names targ_name;
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
NameBCT.store names src_name;
let src_name = (src_name :> name) in
let targ_name =
new scram_name "@" nt_hostbased_service in
NameBCT.store names targ_name;
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 cred = cred_retrieve cred in
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_out
~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 cred = cred_retrieve cred in
let error code =
out
~name:no_name_out ~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 name = name_retrieve name in
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... *)
let _context = context_retrieve context in
out ~minor_status:0l ~major_status:(`None,`Defective_token,[]) ()
method unwrap :
't . context:context ->
input_message:message ->
output_message_preferred_type:[ `String | `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 context = context_retrieve context in
let sk_opt = context # specific_keys in
let error code =
out
~output_message:[] ~conf_state:false ~qop_state:default_qop
~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.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.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:default_qop
~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 context = context_retrieve context in
let sk_opt = context # specific_keys in
if not context#valid then
out
~qop_state:default_qop ~minor_status:0l
~major_status:(`None,`No_context,[]) ()
else
match sk_opt with
| None ->
out
~qop_state:default_qop ~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.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.verify_mic_token
~get_mic:(Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic)
~message
~token) in
if ok then
out
~qop_state:default_qop ~minor_status:0l
~major_status:(`None,`None,flags) ()
else
out
~qop_state:default_qop ~minor_status:0l
~major_status:(`None,`Bad_mic,[]) ()
method wrap :
't . context:context ->
conf_req:bool ->
qop_req:qop option ->
input_message:message ->
output_message_preferred_type:[ `String | `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 () ->
let context = context_retrieve context in
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 <> None && qop_req <> Some default_qop 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.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 option ->
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 () ->
let _context = context_retrieve context in
(* 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,[])
()
end
