(* $Id: netsys_gssapi.ml 2195 2015-01-01 12:23:39Z gerd $ *)

open Printf

type oid = int array
type oid_set = oid list
type token = string
type interprocess_token = string
type calling_error =
    [ `None
    | `Inaccessible_read
    | `Inaccessible_write
    | `Bad_structure
    ]
type routine_error =
    [ `None
    | `Bad_mech
    | `Bad_name
    | `Bad_nametype
    | `Bad_bindings
    | `Bad_status
    | `Bad_mic
    | `No_cred
    | `No_context
    | `Defective_token
    | `Defective_credential
    | `Credentials_expired
    | `Context_expired
    | `Failure
    | `Bad_QOP
    | `Unauthorized
    | `Unavailable
    | `Duplicate_element
    | `Name_not_mn
    ]
type suppl_status =
    [ `Continue_needed
    | `Duplicate_token
    | `Old_token
    | `Unseq_token
    | `Gap_token
    ]
type major_status = calling_error * routine_error * suppl_status list
type minor_status = int32
type address =
    [ `Unspecified of string
    | `Local of string
    | `Inet of Unix.inet_addr
    | `Nulladdr
    | `Other of int32 * string
    ]
type channel_bindings = address * address * string
type cred_usage = [ `Initiate |`Accept | `Both ]
type qop = int32
type message = Netsys_types.mstring list
type ret_flag =
    [ `Deleg_flag | `Mutual_flag | `Replay_flag | `Sequence_flag 
    | `Conf_flag | `Integ_flag | `Anon_flag | `Prot_ready_flag
    | `Trans_flag
    ]
type req_flag = 
    [ `Deleg_flag | `Mutual_flag | `Replay_flag | `Sequence_flag 
    | `Conf_flag | `Integ_flag | `Anon_flag
    ]

type time =
  [ `Indefinite | `This of float]

class type ['credential, 'name, 'context] poly_gss_api =
  object
    method provider : string
    method no_credential : 'credential
    method no_name : 'name
    method is_no_credential : 'credential -> bool
    method is_no_name : 'name -> bool
    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

    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

    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

    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

    method compare_name :
          't . name1:'name ->
               name2:'name ->
               out:( name_equal:bool ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    method context_time :
          't . context:'context ->
               out:( time_rec:time ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    method delete_sec_context :
          't . context:'context ->
               out:( minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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

    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

    method duplicate_name :
           't . name:'name ->
               out:( dest_name:'name ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    method export_name : 
          't . name:'name ->
               out:( exported_name:string ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    method export_sec_context :
          't . context:'context ->
               out:( interprocess_token:interprocess_token ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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

    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

    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

    method indicate_mechs :
          't . out:( mech_set:oid_set ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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:time ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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

    method inquire_cred :
          't . cred:'credential ->
               out:( name:'name ->
		     lifetime: time ->
		     cred_usage:cred_usage ->
		     mechanisms:oid_set ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    method inquire_cred_by_mech :
          't . cred:'credential ->
               mech_type:oid -> 
               out:( name:'name ->
		     initiator_lifetime: time ->
		     acceptor_lifetime: time ->
		     cred_usage:cred_usage ->
		     minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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

    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


    method process_context_token :
          't . context:'context ->
               token:token ->
               out:( minor_status:minor_status ->
		     major_status:major_status ->
		     unit ->
		     't
		   ) -> unit -> 't

    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

    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

    method wrap :
          't . context:'context ->
               conf_req:bool ->
               qop_req:qop ->
               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

    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
  end


module type GSSAPI =
  sig
    type credential
    type context
    type name

    exception Credential of credential
    exception Context of context
    exception Name of name

    class type gss_api = [credential, name, context] poly_gss_api

    val interface : gss_api

end

let string_of_calling_error =
  function
    | `None -> "-"
    | `Inaccessible_read -> "Inaccessible_read"
    | `Inaccessible_write -> "Inaccessible_write"
    | `Bad_structure -> "Bad_structure"

let string_of_routine_error =
  function
    | `None -> "-"
    | `Bad_mech -> "Bad_mech"
    | `Bad_name -> "Bad_name"
    | `Bad_nametype -> "Bad_nametype"
    | `Bad_bindings -> "Bad_bindings"
    | `Bad_status -> "Bad_status"
    | `Bad_mic -> "Bad_mic"
    | `No_cred -> "No_cred"
    | `No_context -> "No_context"
    | `Defective_token -> "Defective_token"
    | `Defective_credential -> "Defective_credential"
    | `Credentials_expired -> "Credentials_expired"
    | `Context_expired -> "Context_expired"
    | `Failure -> "Failure"
    | `Bad_QOP -> "Bad_QOP"
    | `Unauthorized -> "Unauthorized"
    | `Unavailable -> "Unavailable"
    | `Duplicate_element -> "Duplicate_element"
    | `Name_not_mn -> "Name_not_mn"

let string_of_suppl_status =
  function
    | `Continue_needed -> "Continue_needed"
    | `Duplicate_token -> "Duplicate_token"
    | `Old_token -> "Old_token"
    | `Unseq_token -> "Unseq_token"
    | `Gap_token -> "Gap_token"

let string_of_major_status (ce,re,sl) =
  let x = String.concat "," (List.map string_of_suppl_status sl) in
  "<major:" ^ string_of_calling_error ce ^ 
  ";" ^ string_of_routine_error re ^ 
  (if x <> "" then ";" ^ x else "") ^ 
  ">"

let string_of_flag =
  function
  | `Deleg_flag -> "Deleg"
  | `Mutual_flag -> "Mutual"
  | `Replay_flag -> "Replay"
  | `Sequence_flag -> "Sequence"
  | `Conf_flag -> "Conf"
  | `Integ_flag -> "Integ"
  | `Anon_flag -> "Anon"
  | `Prot_ready_flag -> "Prot_ready"
  | `Trans_flag -> "Trans"


let nt_hostbased_service =
  [| 1; 3; 6; 1; 5; 6; 2 |]

let nt_hostbased_service_alt =
  [| 1; 2; 840; 113554; 1; 2; 1; 4 |]

let nt_user_name =
  [| 1; 2; 840; 113554; 1; 2; 1; 1 |]

let nt_machine_uid_name =
  [| 1; 2; 840; 113554; 1; 2; 1; 2 |]

let nt_string_uid_name =
  [| 1; 2; 840; 113554; 1; 2; 1; 3 |]

let nt_anonymous =
  [| 1; 3; 6; 1; 5; 6; 3 |]

let nt_export_name =
  [| 1; 3; 6; 1; 5; 6; 4 |]

let nt_krb5_principal_name =
  [| 1; 2; 840; 113554; 1; 2; 2; 1 |]

let parse_hostbased_service s =
  try
    let k = String.index s '@' in
    (String.sub s 0 k, String.sub s (k+1) (String.length s - k - 1))
  with
    | Not_found ->
	failwith "Netsys_gssapi.parse_hostbased_service"

type support_level =
    [ `Required | `If_possible | `None ]

class type client_config =
object
  method mech_type : oid
  method target_name : (string * oid) option
  method initiator_name : (string * oid) option
  method initiator_cred : exn option
  method privacy : support_level
  method integrity : support_level
  method flags : (req_flag * support_level) list
end

let create_client_config ?(mech_type = [| |]) ?initiator_name ?initiator_cred
                         ?target_name
                         ?(privacy = `If_possible) ?(integrity = `If_possible)
                         ?(flags=[]) () : client_config =
  object
    method mech_type = mech_type
    method target_name = target_name
    method initiator_name = initiator_name
    method initiator_cred = initiator_cred
    method privacy = privacy
    method integrity = integrity
    method flags = flags
  end

class type server_config =
object
  method mech_types : oid list
  method acceptor_name : (string * oid) option
  method privacy : support_level
  method integrity : support_level
  method flags : (req_flag * support_level) list
end

let create_server_config ?(mech_types = []) ?acceptor_name
                         ?(privacy = `If_possible) ?(integrity = `If_possible)
                         ?(flags=[]) () =
  object
    method mech_types = mech_types
    method acceptor_name = acceptor_name
    method privacy = privacy
    method integrity = integrity
    method flags = flags
  end

class type client_props =
object
  method mech_type : oid
  method flags : ret_flag list
  method time : time
end


class type server_props =
object
  method mech_type : oid
  method flags : ret_flag list
  method time : time
  method initiator_name : (string * oid)
  method initiator_name_exported : string
  method deleg_credential : (exn * time) option
end


let marshal_client_props p =
  Marshal.to_string (p#mech_type, p#flags, p#time) []

let unmarshal_client_props s =
  let (mech_type, flags, time) = 
    Marshal.from_string s 0 in
  ( object
      method mech_type = mech_type
      method flags = flags
      method time = time
    end
  )

let marshal_server_props p =
  Marshal.to_string (p#mech_type, p#flags, p#time, p#initiator_name,
                     p#initiator_name_exported) []

let unmarshal_server_props s =
  let (mech_type, flags, time, initiator_name, initiator_name_exported) =
    Marshal.from_string s 0 in
  ( object
      method mech_type = mech_type
      method flags = flags
      method time = time
      method initiator_name = initiator_name
      method initiator_name_exported = initiator_name_exported
      method deleg_credential = None
    end
  )
