(* -*- tuareg -*- *)

open Printf

#use "stubgen.ml"

let types =
  [ "gss_buffer_t",    tagged_abstract_ptr "netgss_free_buffer";
    "gss_OID",         tagged_abstract_ptr ~nullok:true "netgss_free_oid";
    "gss_OID_set",     tagged_abstract_ptr ~nullok:true "netgss_free_oid_set";
    "gss_cred_id_t",   tagged_abstract_ptr ~nullok:true "netgss_free_cred_id";
    "gss_ctx_id_t",    tagged_abstract_ptr ~nullok:true ~gen_set:true "netgss_free_ctx_id";
    "gss_name_t",      tagged_abstract_ptr ~nullok:true "netgss_free_name";
    "gss_channel_bindings_t", abstract_ptr ~nullok:true "netgss_free_cb";

    "gss_cred_usage_t", `Enum [ "GSS_C_|BOTH";
                                "GSS_C_|INITIATE";
                                "GSS_C_|ACCEPT"
                              ];
    "flags",            `Flags [ "GSS_C_|DELEG_FLAG";
                                 "GSS_C_|MUTUAL_FLAG";
                                 "GSS_C_|REPLAY_FLAG";
                                 "GSS_C_|SEQUENCE_FLAG";
                                 "GSS_C_|CONF_FLAG";
                                 "GSS_C_|INTEG_FLAG";
                                 "GSS_C_|ANON_FLAG";
                                 "GSS_C_|PROT_READY_FLAG";
                                 "GSS_C_|TRANS_FLAG";
                               ];
    "gss_qop_t",        `Enum [ "GSS_C_|QOP_DEFAULT" ];
    "status_type_t",    `Enum [ "GSS_C_|GSS_CODE";
                                "GSS_C_|MECH_CODE";
                              ];
  ]

(* OM_uint32: refer to this as "OM_uint32/int32" *)

let standard ?(optional=false) ?(options=[]) decl =
  let (name, result, params) = parse decl in
  (name,
   params @ [ "result",
              (if result = "void" then `Return_ignore else `Return),
              result
            ],
   (if optional then [ `Optional ] else []) @
     options
  )

let functions =
  [ standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_accept_sec_context( \
               OUT OM_uint32/int32  minor_status, \
               IN_OUT gss_ctx_id_t  context, \
               gss_cred_id_t        acceptor_cred, \
               gss_buffer_t         input_token, \
               gss_channel_bindings_t chan_bindings, \
               OUT gss_name_t       src_name, \
               OUT gss_OID          mech_type, \
               OUT_NOPTR gss_buffer_t output_token, \
               OUT flags            ret_flags, \
               OUT OM_uint32/int32  time_rec, \
               OUT gss_cred_id_t    delegated_cred)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_acquire_cred( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           desired_name, \
               OM_uint32/int32      time_req, \
               gss_OID_set          desired_mechs, \
               gss_cred_usage_t     cred_usage, \
               OUT gss_cred_id_t    cred, \
               OUT gss_OID_set      actual_mechs, \
               OUT OM_uint32/int32  time_rec)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_init_sec_context( \
               OUT OM_uint32/int32  minor_status, \
               gss_cred_id_t        initiator_cred, \
               IN_OUT gss_ctx_id_t  context, \
               gss_name_t           target_name, \
               gss_OID              mech_type, \
               flags                req_flags, \
               OM_uint32/int32      time_req, \
               gss_channel_bindings_t chan_bindings, \
               gss_buffer_t         input_token, \
               OUT gss_OID          actual_mech_type, \
               OUT_NOPTR gss_buffer_t output_token, \
               OUT flags            ret_flags, \
               OUT OM_uint32/int32  time_rec)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_process_context_token( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               gss_buffer_t         token)";

    standard
      "OM_uint32/int32 \
           gss_context_time( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               OUT OM_uint32/int32  time_rec)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_get_mic( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               OM_uint32/int32      qop_req, \
               gss_buffer_t         message, \
               OUT_NOPTR gss_buffer_t msg_token)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_verify_mic( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               gss_buffer_t         message, \
               gss_buffer_t         token, \
               OUT OM_uint32/int32  qop_state)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_wrap( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               bool                 conf_req, \
               OM_uint32/int32      qop_req, \
               gss_buffer_t         input_message, \
               OUT bool             conf_state, \
               OUT_NOPTR gss_buffer_t output_message)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_unwrap( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               gss_buffer_t         input_message, \
               OUT_NOPTR gss_buffer_t output_message, \
               OUT bool             conf_state, \
               OUT OM_uint32/int32  qop_state)";

    standard
      "OM_uint32/int32 \
           gss_display_status( \
               OUT OM_uint32/int32  minor_status, \
               OM_uint32/int32      status_value, \
               status_type_t        status_type, \
               gss_OID              mech_type, \
               IN_OUT OM_uint32/int32 message_context, \
               OUT_NOPTR gss_buffer_t status_string)";

    standard
      "OM_uint32/int32 \
           gss_indicate_mechs( \
               OUT OM_uint32/int32  minor_status, \
               OUT gss_OID_set      mech_set)";

    standard
      "OM_uint32/int32 \
           gss_compare_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           name1, \
               gss_name_t           name2, \
               OUT bool             name_equal)";

    standard
      "OM_uint32/int32 \
           gss_display_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           input_name, \
               OUT_NOPTR gss_buffer_t output_name, \
               OUT gss_OID          output_name_type)";

    standard
      "OM_uint32/int32 \
           gss_import_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_buffer_t         input_name, \
               gss_OID              input_name_type, \
               OUT gss_name_t       output_name)";

    standard
      "OM_uint32/int32 \
           gss_inquire_cred( \
               OUT OM_uint32/int32  minor_status, \
               gss_cred_id_t        cred, \
               OUT gss_name_t       name, \
               OUT OM_uint32/int32  lifetime, \
               OUT gss_cred_usage_t cred_usage, \
               OUT gss_OID_set      mechanisms)";

    standard
      "OM_uint32/int32 \
           gss_inquire_context( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               OUT gss_name_t       src_name, \
               OUT gss_name_t       targ_name, \
               OUT OM_uint32/int32  lifetime_req, \
               OUT gss_OID          mech_type, \
               OUT flags            ctx_flags, \
               OUT bool             locally_initiated, \
               OUT bool             is_open)";

    standard
      "OM_uint32/int32 \
           gss_wrap_size_limit( \
               OUT OM_uint32/int32  minor_status, \
               gss_ctx_id_t         context, \
               bool                 conf_req, \
               OM_uint32/int32      qop_req, \
               OM_uint32/int32      req_output_size, \
               OUT OM_uint32/int32  max_input_size)";

    standard
      ~options:[`Blocking]
      "OM_uint32/int32 \
           gss_add_cred( \
               OUT OM_uint32/int32  minor_status, \
               gss_cred_id_t        input_cred, \
               gss_name_t           desired_name, \
               gss_OID              desired_mech, \
               gss_cred_usage_t     cred_usage, \
               OM_uint32/int32      initiator_time_req, \
               OM_uint32/int32      acceptor_time_req, \
               OUT gss_cred_id_t    output_cred, \
               OUT gss_OID_set      actual_mechs, \
               OUT OM_uint32/int32  initiator_time_rec, \
               OUT OM_uint32/int32  acceptor_time_rec)";

    standard
      "OM_uint32/int32 \
           gss_inquire_cred_by_mech( \
               OUT OM_uint32/int32  minor_status, \
               gss_cred_id_t        cred, \
               gss_OID              mech_type, \
               OUT gss_name_t       name, \
               OUT OM_uint32/int32  initiator_lifetime, \
               OUT OM_uint32/int32  acceptor_lifetime, \
               OUT gss_cred_usage_t cred_usage)";

    standard
      ~options: [ `Post "if (context__c == GSS_C_NO_CONTEXT) set_gss_ctx_id_t(context, GSS_C_NO_CONTEXT);"; ]
      "OM_uint32/int32 \
           gss_export_sec_context( \
               OUT OM_uint32/int32  minor_status, \
               IN_PTR gss_ctx_id_t  context, \
               OUT_NOPTR gss_buffer_t interprocess_token)";

    standard
      "OM_uint32/int32 \
           gss_import_sec_context( \
               OUT OM_uint32/int32  minor_status, \
               gss_buffer_t         interprocess_token, \
               OUT gss_ctx_id_t     context)";

    standard
      "OM_uint32/int32 \
           gss_inquire_names_for_mech( \
               OUT OM_uint32/int32  minor_status, \
               gss_OID              mechanism, \
               OUT gss_OID_set      name_types)";

    standard
      "OM_uint32/int32 \
           gss_inquire_mechs_for_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           name, \
               OUT gss_OID_set      mech_types)";

    standard
      "OM_uint32/int32 \
           gss_export_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           name, \
               OUT_NOPTR gss_buffer_t  exported_name)";

    standard
      "OM_uint32/int32 \
           gss_duplicate_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           name, \
               OUT gss_name_t       dest_name)";
    
    standard
      "OM_uint32/int32 \
           gss_canonicalize_name( \
               OUT OM_uint32/int32  minor_status, \
               gss_name_t           input_name, \
               gss_OID              mech_type, \
               OUT gss_name_t       output_name)";

    standard
      ~options:[ `Pre "output_token__c = GSS_C_NO_BUFFER;";
                 `Post "if ((result__c & 0xffff0000) == 0) set_gss_ctx_id_t(context, GSS_C_NO_CONTEXT);";
               ]
      "OM_uint32/int32 \
           gss_delete_sec_context( \
               OUT OM_uint32/int32  minor_status, \
               IN_PTR gss_ctx_id_t  context, \
               IN_IGNORE gss_buffer_t output_token)";

  ]


let optional_types = []
let optional_functions = []

(* Generate the module Netgss_bindings *)

let () =
  generate 
    ~c_file:"gssapi.c"
    ~ml_file:"gssapi.ml"
    ~mli_file:"gssapi.mli"
    ~modname:"netgss_bindings"
    ~types
    ~functions
    ~optional_functions
    ~optional_types
    ~free: []
    ~init: [ "gss_buffer_t" ]
    ~hashes:[]
    ~enum_of_string:[]
    ()


(* Generate the implementation of Netgss: *)

let mapping =
  (* (c_type, fn_name, arg_name, ocaml_type). "*" is a wildcard *)
  [ "gss_buffer_t",     "*", "message",            "message";
    "gss_buffer_t",     "*", "input_message",      "message";
    "gss_buffer_t",     "*", "output_message",     "message";
    "gss_buffer_t",     "gss_init_sec_context", "input_token", "token_option";
    "gss_buffer_t",     "*", "*",                  "token";

    "gss_ctx_id_t",     "gss_accept_sec_context", "*", "context_option";
    "gss_ctx_id_t",     "gss_import_sec_context", "*", "context_option";
    "gss_ctx_id_t",     "gss_init_sec_context",  "*", "context_option";

    "flags",            "gss_init_sec_context",  "req_flags", "req_flags";

    "gss_channel_bindings_t","*",  "*",            "cb_option";
    "gss_OID",          "*", "*",                  "oid";
    "gss_OID_set",      "*", "*",                  "oid_set";

    "OM_uint32/int32",  "gss_wrap_size_limit", "req_output_size", "wrap_size";
    "OM_uint32/int32",  "gss_wrap_size_limit", "max_input_size", "wrap_size";
    "OM_uint32/int32",  "gss_init_sec_context", "time_req", "time_opt";
    
    "OM_uint32/int32",  "*", "time_req",            "time";
    "OM_uint32/int32",  "*", "initiator_time_req",  "time";
    "OM_uint32/int32",  "*", "acceptor_time_req",   "time";
    "OM_uint32/int32",  "*", "time_rec",            "time";
    "OM_uint32/int32",  "*", "initiator_time_rec",  "time";
    "OM_uint32/int32",  "*", "acceptor_time_rec",   "time";
    "OM_uint32/int32",  "*", "lifetime",            "time";
    "OM_uint32/int32",  "*", "lifetime_req",        "time";
    "OM_uint32/int32",  "*", "initiator_lifetime",  "time";
    "OM_uint32/int32",  "*", "acceptor_lifetime",   "time";

    "OM_uint32/int32",  "*", "*",                   "int32";
  ]

let map_name fn_name arg_name ty_name =
  try
    let (_, _, _, oname) =
      List.find
        (fun (n1, n2, n3, n4) ->
           n1 = ty_name &&
             (n2 = fn_name || n2 = "*") &&
             (n3 = arg_name || n3 = "*")
        )
        mapping in
    oname
  with
    | Not_found ->
         ty_name

let prep_ty_name ty_name =
  try
    let p = String.index ty_name '/' in
    String.sub ty_name 0 p
  with Not_found ->
    ty_name


let strip_gss name =
  if String.length name >= 4 && String.sub name 0 4 = "gss_" then
    String.sub name 4 (String.length name - 4)
  else
    name

(*
delete_sec_context:
 - missing

 *)

let fixup_accept_sec_context =
  (* the output args for the method: pairs (new_name, old_name) *)
  [ "src_name",         "src_name";
    "mech_type",        "mech_type";
    "output_context",   "context";      (* ! *)
    "output_token",     "output_token";
    "ret_flags",        "ret_flags";
    "time_rec",         "time_rec";
    "delegated_cred",   "delegated_cred";
  ]

let fixup_export_sec_context =
  (* delete the output context *)
  [ "interprocess_token",  "interprocess_token"; 
  ]

let fixup_init_sec_context =
  [ "actual_mech_type",   "actual_mech_type";
    "output_context",     "context";    (* ! *)
    "output_token",       "output_token";
    "ret_flags",          "ret_flags";
    "time_rec",           "time_rec";
  ]

let fixups = 
  [ "gss_accept_sec_context", fixup_accept_sec_context;
    "gss_export_sec_context", fixup_export_sec_context;
    "gss_init_sec_context",   fixup_init_sec_context
  ]

let fixup fn_name out_params =
  try
    let fixup_list = List.assoc fn_name fixups in
    List.map
      (fun (ocaml_name, c_name) ->
         let (_, p_kind, p_type) =
           try
             List.find (fun (n,_,_) -> n = c_name) out_params
           with Not_found ->
             failwith (sprintf "Not found: fn=%s c_name=%s" fn_name c_name) in
         (ocaml_name, c_name, p_kind, p_type)
      )
      fixup_list
  with
    | Not_found -> 
         List.map
           (fun (n, p_kind, p_type) -> (n,n,p_kind,p_type))
           out_params


let functions =
  List.filter (fun (n, _, _) -> n <> "gss_display_status") functions
  @ [ "gss_display_minor_status",
      [ "status_value", `In, "int32";
        "mech_type", `In, "gss_OID";
        "status_strings", `Out, "string list";
      ],
      []
    ]


let () =
  let f = open_out "netgss.ml" in
  fprintf f "(* generated file, do not edit *)\n";
  fprintf f "module System : Netsys_gssapi.GSSAPI = struct\n";
  fprintf f "  open Netsys_gssapi\n";
  fprintf f "  open Netgss_bindings\n";
  fprintf f "  include Netgss_util\n";
  fprintf f "\n";
  fprintf f "  type credential = gss_cred_id_t\n";
  fprintf f "  type context = gss_ctx_id_t\n";
  fprintf f "  type name = gss_name_t\n";
  fprintf f "  type context_option = context option\n";
  fprintf f "  type cb_option = channel_bindings option\n";
  fprintf f "  type ret_flags = ret_flag list\n";
  fprintf f "  type time_opt = float option\n";
  fprintf f "  type wrap_size = int\n";
  fprintf f "  type req_flags = req_flag list\n";
  fprintf f "  type token_option = token option\n";
  fprintf f "\n";
  fprintf f "  exception Credential of credential\n";
  fprintf f "  exception Context of context\n";
  fprintf f "  exception Name of name\n";
  fprintf f "\n";
  fprintf f "  class type gss_api = \
                 [ credential, name, context ] Netsys_gssapi.poly_gss_api\n";
  fprintf f "\n";

  fprintf f "  let interface : gss_api =\n";
  fprintf f "    ( object\n";

  fprintf f "        method provider = \"Netsys_gssapi.System\"\n";
  fprintf f "        method no_credential = no_credential()\n";
  fprintf f "        method no_name = no_name()\n";
  fprintf f "        method is_no_credential = is_no_credential\n";
  fprintf f "        method is_no_name = is_no_name\n";

  let indent = "        " in

  List.iter
    (fun (fn_name, params, _) ->
       fprintf f "%smethod %s :\n" indent (strip_gss fn_name);

       (* First generate the (polymorphic) method type: *)

       fprintf f "%s  't .\n" indent;

       let input_params =
         List.filter
           (fun (p_name, p_kind, _) ->
              (p_kind = `In || p_kind = `In_out || p_kind = `In_ptr) &&
                p_name <> "minor_status"
           )
           params in

       let output_params =
         List.filter
           (fun (p_name, p_kind, _) ->
              (p_kind = `Out || p_kind = `Out_noptr || p_kind = `In_out) &&
                p_name <> "minor_status"
           )
           params in

       let output_params_fixed = fixup fn_name output_params in

       List.iter
         (fun (p_name, p_kind, p_type) ->
            let ocaml_type = map_name fn_name p_name p_type in
            fprintf f "%s    %s:%s ->\n" indent p_name ocaml_type;
         )
         input_params;

       (* HACK for wrap/unwrap: *)
       if fn_name = "gss_unwrap" || fn_name = "gss_wrap" then (
         fprintf f "%s    output_message_preferred_type:[`Bytes|`Memory] ->\n"
                 indent
       );

       fprintf f "%s    out:(\n" indent;

       List.iter
         (fun (p_name_ocaml, p_name, p_kind, p_type) ->
            let ocaml_type = map_name fn_name p_name p_type in
            fprintf f "%s      %s:%s ->\n" indent p_name_ocaml ocaml_type;
         )
         output_params_fixed;

       fprintf f "%s      minor_status:minor_status ->\n" indent;
       fprintf f "%s      major_status:major_status ->\n" indent;
       fprintf f "%s      unit ->\n" indent;
       fprintf f "%s      't\n" indent;
       fprintf f "%s    ) -> unit -> 't =\n" indent;

       (* Now generate the method body: *)

       fprintf f "%s  fun" indent;
       List.iter
         (fun (p_name, p_kind, p_type) ->
            fprintf f " ~%s" p_name
         )
         input_params;

       (* HACK for wrap/unwrap: *)
       if fn_name = "gss_unwrap" || fn_name = "gss_wrap" then (
         fprintf f " ~output_message_preferred_type"
       );

       fprintf f " ~out () ->\n";
       
       (* Buffer management: *)
       let have_buffers =
         List.exists
           (fun (_, _, p_type) -> p_type = "gss_buffer_t")
           input_params in
       if have_buffers then (
         fprintf f "%s    let buffers = ref [] in\n" indent;
         fprintf f "%s    let release_soon f arg = \
                            let buf = f arg in \
                            buffers := buf :: !buffers; \
                            buf in\n" indent;
       );

       (* Catching call results: *)
       fprintf f "%s    let major_status, minor_status" indent;
       List.iter
         (fun (p_name, p_kind, p_type) ->
            fprintf f ", %s" p_name
         )
         output_params;
       fprintf f " = \n";

       (* Call: *)
       fprintf f "%s      %s" indent fn_name;

       (* Arguments: *)
       List.iter
         (fun (p_name, p_kind, p_type) ->
            let ocaml_type = map_name fn_name  p_name p_type in
            let in_convert0 =
              if p_type = ocaml_type then
                "identity"
              else
                sprintf "_%s_of_%s" (prep_ty_name p_type) ocaml_type in
            let in_convert =
              if p_type = "gss_buffer_t" then
                "release_soon " ^ in_convert0
              else
            in_convert0 in
            fprintf f "\n%s        (%s %s)" indent in_convert p_name
         )
         input_params;
       if input_params = [] then
         fprintf f "\n%s        ()" indent;

       fprintf f " in\n";

       (* Buffer management: *)
       if have_buffers then
         fprintf f "%s    List.iter release_buffer !buffers;\n" indent;

       (* Invoke the "out" function: *)
       fprintf f "%s    out" indent;

       (* Out arguments: *)
       List.iter
         (fun (p_name_ocaml, p_name, p_kind, p_type) ->
            let ocaml_type = map_name fn_name p_name p_type in
            let out_convert =
              if p_type = ocaml_type then
                "identity"
              else
                if ocaml_type = "message" then
                  "(_message_of_gss_buffer_t output_message_preferred_type)"
                else
                  sprintf "_%s_of_%s" ocaml_type (prep_ty_name p_type) in
            fprintf f "\n%s      ~%s:(%s %s)" 
                    indent p_name_ocaml out_convert p_name
         )
         output_params_fixed;

       (* Standard out arguments: *)
       fprintf f "\n%s      ~minor_status" indent;
       fprintf f "\n%s      ~major_status:(decode_status major_status)" indent;
       fprintf f "\n%s      ()\n" indent;
    )
    functions;

  fprintf f "      end\n";
  fprintf f "    )\n";
  fprintf f "end\n";
  close_out f




