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