← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to src/netmech-scram/netmech_scram_gssapi.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/netmech-scram/netmech_scram_gssapi.ml
 
1
(* $Id: netmech_scram_gssapi.ml 1562 2011-03-07 16:13:14Z gerd $ *)
 
2
 
 
3
(* FIXME:
 
4
   - export_sec_context: the token does not include the sequence numbers,
 
5
     and it does not include the flags
 
6
 *)
 
7
 
 
8
open Netgssapi
 
9
open Printf
 
10
 
 
11
class scram_name (name_string:string) (name_type:oid) =
 
12
object
 
13
  method otype = ( `Name :  [`Name] )
 
14
  method name_string = name_string
 
15
  method name_type = name_type
 
16
end
 
17
 
 
18
 
 
19
type cred =
 
20
  | Cred_server                      (* there are no server credentials! *)
 
21
  | Cred_client of string * string   (* user name, password *)
 
22
  | Cred_none
 
23
 
 
24
 
 
25
class scram_cred (name:name) (cred:cred) =
 
26
object
 
27
  method otype = ( `Credential : [`Credential] )
 
28
  method name = name
 
29
  method cred = cred
 
30
end
 
31
 
 
32
 
 
33
type ctx =
 
34
  | Ctx_client of Netmech_scram.client_session
 
35
  | Ctx_server of Netmech_scram.server_session
 
36
 
 
37
class scram_context ctx (init_flags : ret_flag list) =
 
38
  let valid = ref true in
 
39
  let server_cb = ref "" in
 
40
  let specific_keys = ref None in
 
41
  let seq_nr = ref 0L in
 
42
  let exp_seq_nr = ref None in
 
43
  let flags = ref init_flags in
 
44
object
 
45
  method otype = ( `Context : [ `Context ] )
 
46
  method valid = !valid
 
47
  method ctx = ctx
 
48
  method delete() = valid := false
 
49
  method server_cb = server_cb
 
50
  method is_acceptor =
 
51
    match ctx with
 
52
      | Ctx_client _ -> false
 
53
      | Ctx_server _ -> true
 
54
  method specific_keys =
 
55
    match !specific_keys with
 
56
      | Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> 
 
57
          Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s)
 
58
      | None ->
 
59
          let proto_key_opt =
 
60
            match ctx with
 
61
              | Ctx_client sess -> 
 
62
                  Netmech_scram.client_protocol_key sess
 
63
              | Ctx_server sess -> 
 
64
                  Netmech_scram.server_protocol_key sess in
 
65
          (* The usage numbers are defined in RFC 4121 *)
 
66
          (match proto_key_opt with
 
67
             | None -> None
 
68
             | Some proto_key ->
 
69
                 let k_mic_c = 
 
70
                   Netmech_scram.Cryptosystem.derive_keys
 
71
                     proto_key 25 in
 
72
                 let k_mic_s = 
 
73
                   Netmech_scram.Cryptosystem.derive_keys
 
74
                     proto_key 23 in
 
75
                 let k_wrap_c = 
 
76
                   Netmech_scram.Cryptosystem.derive_keys
 
77
                     proto_key 24 in
 
78
                 let k_wrap_s = 
 
79
                   Netmech_scram.Cryptosystem.derive_keys
 
80
                     proto_key 22 in
 
81
(*
 
82
eprintf "protocol key: %S\n" proto_key;
 
83
eprintf "k_mic_c.kc: %S\n" k_mic_c.Netmech_scram.kc;
 
84
eprintf "k_mic_s.kc: %S\n" k_mic_s.Netmech_scram.kc;
 
85
eprintf "k_wrap_c.ke: %S\n" k_wrap_c.Netmech_scram.ke;
 
86
eprintf "k_wrap_c.ki: %S\n" k_wrap_c.Netmech_scram.ki;
 
87
eprintf "k_wrap_s.ke: %S\n" k_wrap_s.Netmech_scram.ke;
 
88
eprintf "k_wrap_s.ki: %S\n%!" k_wrap_s.Netmech_scram.ki;
 
89
 *)
 
90
                 specific_keys := Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s);
 
91
                 !specific_keys
 
92
          )
 
93
  method seq_nr = 
 
94
    let n = !seq_nr in
 
95
    seq_nr := Int64.succ !seq_nr;
 
96
    n
 
97
 
 
98
  method is_peer_seq_nr_ok n : suppl_status list =
 
99
    match !exp_seq_nr with
 
100
      | None ->
 
101
          exp_seq_nr := Some n;
 
102
          []
 
103
      | Some e ->
 
104
          if n = e then (
 
105
            exp_seq_nr := Some (Int64.succ e);
 
106
            []
 
107
          ) else (
 
108
            if n < e then
 
109
              [ `Unseq_token ]
 
110
            else
 
111
              [ `Gap_token ]
 
112
          )
 
113
 
 
114
  method flags = flags
 
115
end
 
116
 
 
117
 
 
118
 
 
119
module type BACK_COERCE_OBJECT = sig
 
120
  type t
 
121
  val hide : t -> < >
 
122
  val exhibit : < > -> t
 
123
end
 
124
 
 
125
 
 
126
module Back_coerce_table(T:BACK_COERCE_OBJECT) : sig 
 
127
  type table
 
128
  val create : unit -> table
 
129
  val store : table -> T.t -> unit
 
130
  val retrieve : table -> < > -> T.t
 
131
end = struct
 
132
  module E = struct
 
133
    type t = < >
 
134
    let equal x y = x = y
 
135
    let hash x = Hashtbl.hash x
 
136
  end
 
137
 
 
138
  module W = Weak.Make(E)
 
139
 
 
140
  type table = W.t
 
141
 
 
142
  let create() =
 
143
    W.create 10
 
144
 
 
145
  let store table (x : T.t) =
 
146
    ignore(W.merge table (T.hide x))
 
147
 
 
148
  let retrieve table (x : < >) : T.t =
 
149
    if W.mem table x then
 
150
      T.exhibit x
 
151
    else
 
152
      invalid_arg "Netmech_scram_gssapi: Unknown opaque object"
 
153
end
 
154
 
 
155
module Credential = struct
 
156
  type t = scram_cred
 
157
  let hide x = (x :> < >)
 
158
  let exhibit x = (Obj.magic x : t)
 
159
end
 
160
 
 
161
module CredentialBCT = Back_coerce_table(Credential)
 
162
 
 
163
module Name = struct
 
164
  type t = scram_name
 
165
  let hide x = (x :> < >)
 
166
  let exhibit x = (Obj.magic x : t)
 
167
end
 
168
 
 
169
module NameBCT = Back_coerce_table(Name)
 
170
 
 
171
module Context = struct
 
172
  type t = scram_context
 
173
  let hide x = (x :> < > )
 
174
  let exhibit x = (Obj.magic x : t)
 
175
end
 
176
 
 
177
 
 
178
module ContextBCT = Back_coerce_table(Context)
 
179
 
 
180
 
 
181
class type client_key_ring =
 
182
object
 
183
  method password_of_user_name : string -> string
 
184
  method default_user_name : string option
 
185
end
 
186
 
 
187
 
 
188
let empty_client_key_ring : client_key_ring =
 
189
object
 
190
  method password_of_user_name _ = raise Not_found
 
191
  method default_user_name = None
 
192
end
 
193
 
 
194
 
 
195
class type server_key_verifier =
 
196
object
 
197
  method scram_credentials : string -> string * string * int
 
198
end
 
199
 
 
200
 
 
201
let empty_server_key_verifier : server_key_verifier =
 
202
object
 
203
  method scram_credentials _ = raise Not_found
 
204
end
 
205
 
 
206
let scram_mech = [| 1; 3; 6; 1; 5; 5; 14 |]
 
207
 
 
208
 
 
209
(*
 
210
let as_string (sm,pos,len) =
 
211
  match sm with
 
212
    | `String s ->
 
213
        if pos=0 && len=String.length s then
 
214
          s
 
215
        else
 
216
          String.sub s pos len
 
217
    | `Memory m -> 
 
218
        let s = String.create len in
 
219
        Netsys_mem.blit_memory_to_string m pos s 0 len;
 
220
        s
 
221
 *)
 
222
 
 
223
(*
 
224
let empty_msg = (`String "",0,0)
 
225
 *)
 
226
 
 
227
exception Calling_error of calling_error
 
228
exception Routine_error of routine_error
 
229
 
 
230
 
 
231
class scram_gss_api ?(client_key_ring = empty_client_key_ring)
 
232
                    ?(server_key_verifier = empty_server_key_verifier)
 
233
                    profile
 
234
                    : gss_api =
 
235
  let scram_ret_flags =
 
236
    [ `Mutual_flag; `Conf_flag; `Integ_flag; `Replay_flag; `Sequence_flag ] in
 
237
 
 
238
  let credentials = CredentialBCT.create() in
 
239
  let names = NameBCT.create() in
 
240
  let contexts = ContextBCT.create() in
 
241
  let cred_retrieve obj =
 
242
    CredentialBCT.retrieve credentials (obj : credential :> < >) in
 
243
  let name_retrieve obj =
 
244
    NameBCT.retrieve names (obj : name :> < >) in
 
245
  let context_retrieve obj =
 
246
    ContextBCT.retrieve contexts (obj : context :> < >) in
 
247
  let no_cred = 
 
248
    ( object
 
249
        method otype = `Credential 
 
250
        method name = assert false
 
251
        method cred = Cred_none
 
252
      end
 
253
    ) in
 
254
  let no_cred_out = (no_cred :> credential) in
 
255
  let () = CredentialBCT.store credentials no_cred in
 
256
  let no_name =
 
257
    ( object
 
258
        method otype = `Name
 
259
        method name_type = [| |]
 
260
        method name_string = ""
 
261
      end
 
262
    ) in
 
263
  let no_name_out = (no_name :> name) in
 
264
  let () = NameBCT.store names no_name in
 
265
  let default_qop =
 
266
    ( object method otype = `QOP end ) in  (* just return something *)
 
267
object(self)
 
268
  method provider = "Netmech_scram_gssapi.scap_gss_api"
 
269
 
 
270
  method no_credential = (no_cred :> credential)
 
271
 
 
272
  method no_name = (no_name :> name)
 
273
 
 
274
  method accept_sec_context : 
 
275
          't . context:context option ->
 
276
               acceptor_cred:credential -> 
 
277
               input_token:token ->
 
278
               chan_bindings:channel_bindings option ->
 
279
               out:( src_name:name ->
 
280
                     mech_type:oid ->
 
281
                     output_context:context option ->
 
282
                     output_token:token ->
 
283
                     ret_flags:ret_flag list ->
 
284
                     time_rec:[ `Indefinite | `This of float] ->
 
285
                     delegated_cred:credential ->
 
286
                     minor_status:minor_status ->
 
287
                     major_status:major_status ->
 
288
                     unit ->
 
289
                     't 
 
290
                   ) -> unit -> 't =
 
291
    fun ~context ~acceptor_cred ~input_token ~chan_bindings ~out () ->
 
292
      let acc_name =
 
293
        new scram_name "@" nt_hostbased_service in
 
294
      NameBCT.store names acc_name;
 
295
      let src_name = (acc_name :> name) in
 
296
      try
 
297
        let cb_data =
 
298
          match chan_bindings with
 
299
            | None -> ""
 
300
            | Some (init_addr, acc_addr, cb_data) -> cb_data in
 
301
        (* We ignore init_addr and acc_addr... CHECK *)
 
302
        let acceptor_cred =
 
303
          cred_retrieve acceptor_cred in
 
304
        if acceptor_cred <> no_cred && acceptor_cred#cred <> Cred_server then
 
305
          raise(Routine_error `No_cred);
 
306
        let context, sess, is_first =
 
307
          match context with
 
308
            | None ->
 
309
                let sess =
 
310
                  Netmech_scram.create_server_session
 
311
                    profile
 
312
                    server_key_verifier#scram_credentials in
 
313
                let ctx =
 
314
                  Ctx_server sess in
 
315
                let context = new scram_context ctx scram_ret_flags in
 
316
                (context # server_cb) := cb_data;
 
317
                ContextBCT.store contexts context;
 
318
                (context, sess, true)
 
319
            | Some c -> 
 
320
                let context = context_retrieve c in
 
321
                if not context#valid then
 
322
                  raise (Routine_error `No_context);
 
323
                let sess =
 
324
                  match context#ctx with
 
325
                    | Ctx_server sess -> sess
 
326
                    | Ctx_client _ -> raise (Routine_error `No_context) in
 
327
                (context, sess, false) in
 
328
        let eff_input_token =
 
329
          if is_first then (* There is a header *)
 
330
            try
 
331
              let k = ref 0 in
 
332
              let (oid, tok) = Netgssapi.wire_decode_token input_token k in
 
333
              if !k <> String.length input_token then
 
334
                raise(Routine_error `Defective_token);
 
335
              if oid <> scram_mech then
 
336
                raise(Routine_error `Bad_mech);
 
337
              tok
 
338
            with
 
339
              | Failure _ ->
 
340
                  raise(Routine_error `Defective_token);
 
341
          else
 
342
            input_token in
 
343
        (* The following call usually does not raise exceptions. Error codes
 
344
           are stored inside sess
 
345
         *)
 
346
        Netmech_scram.server_recv_message sess eff_input_token;
 
347
        let output_context =
 
348
          Some (context :> context) in
 
349
        let output_token =
 
350
          Netmech_scram.server_emit_message sess in
 
351
        if Netmech_scram.server_error_flag sess then (
 
352
          out
 
353
            ~src_name ~mech_type:scram_mech ~output_context
 
354
            ~output_token
 
355
            ~ret_flags:scram_ret_flags ~time_rec:`Indefinite
 
356
            ~delegated_cred:no_cred_out
 
357
            ~minor_status:0l ~major_status:(`None,`Failure,[]) ()
 
358
        )
 
359
        else
 
360
          if Netmech_scram.server_finish_flag sess then (
 
361
            (* Finally check channel bindings: *)
 
362
            let scram_cb =
 
363
              match Netmech_scram.server_channel_binding sess with
 
364
                | None -> assert false
 
365
                | Some d -> d in
 
366
            if scram_cb <> !(context # server_cb) then
 
367
              raise(Routine_error `Bad_bindings);
 
368
            let ret_flags =
 
369
              [`Prot_ready_flag; `Trans_flag] @ scram_ret_flags in 
 
370
            context # flags := ret_flags;
 
371
            out
 
372
              ~src_name ~mech_type:scram_mech ~output_context
 
373
              ~output_token
 
374
              ~ret_flags
 
375
              ~time_rec:`Indefinite
 
376
              ~delegated_cred:no_cred_out
 
377
              ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
378
          )
 
379
          else (
 
380
            out
 
381
              ~src_name ~mech_type:scram_mech ~output_context
 
382
              ~output_token
 
383
              ~ret_flags:scram_ret_flags ~time_rec:`Indefinite
 
384
              ~delegated_cred:no_cred_out
 
385
              ~minor_status:0l ~major_status:(`None,`None,[`Continue_needed])
 
386
              ()
 
387
          )
 
388
      with
 
389
        | Calling_error code ->
 
390
            out
 
391
              ~src_name ~mech_type:scram_mech ~output_context:None
 
392
              ~output_token:""
 
393
              ~ret_flags:scram_ret_flags ~time_rec:`Indefinite
 
394
              ~delegated_cred:no_cred_out
 
395
              ~minor_status:0l ~major_status:(code,`None,[]) ()
 
396
        | Routine_error code ->
 
397
            out
 
398
              ~src_name ~mech_type:scram_mech ~output_context:None
 
399
              ~output_token:""
 
400
              ~ret_flags:scram_ret_flags ~time_rec:`Indefinite
 
401
              ~delegated_cred:no_cred_out
 
402
              ~minor_status:0l ~major_status:(`None,code,[]) ()
 
403
 
 
404
  method private get_client_cred user =  (* or Not_found *)
 
405
    let pw = client_key_ring # password_of_user_name user in
 
406
    let name =
 
407
      new scram_name user nt_user_name in
 
408
    NameBCT.store names name;
 
409
    let cred = 
 
410
      new scram_cred (name:>name) (Cred_client(user,pw)) in
 
411
    CredentialBCT.store credentials cred;
 
412
    cred
 
413
 
 
414
  method private get_default_client_cred() = (* or Not_found *)
 
415
    match client_key_ring # default_user_name with
 
416
      | None -> raise Not_found
 
417
      | Some user -> self # get_client_cred user
 
418
    
 
419
  method acquire_cred :
 
420
          't . desired_name:name ->
 
421
               time_req:[`None | `Indefinite | `This of float] ->
 
422
               desired_mechs:oid_set ->
 
423
               cred_usage:cred_usage  ->
 
424
               out:( cred:credential ->
 
425
                     actual_mechs:oid_set ->
 
426
                     time_rec:[ `Indefinite | `This of float] ->
 
427
                     minor_status:minor_status ->
 
428
                     major_status:major_status ->
 
429
                     unit ->
 
430
                     't
 
431
                   ) -> unit -> 't =
 
432
    fun ~desired_name ~time_req ~desired_mechs ~cred_usage ~out ()  ->
 
433
      let desired_name = name_retrieve desired_name in
 
434
      let error code =
 
435
        out
 
436
          ~cred:no_cred_out ~actual_mechs:[] ~time_rec:`Indefinite
 
437
          ~minor_status:0l ~major_status:(`None,code,[]) () in
 
438
      match cred_usage with
 
439
        | `Initiate ->
 
440
            (* For clients *)
 
441
            if List.mem scram_mech desired_mechs then (
 
442
              let out_client_cred user =
 
443
                try
 
444
                  let cred = self#get_client_cred user in
 
445
                  out
 
446
                    ~cred:(cred :> credential)
 
447
                    ~actual_mechs:[ scram_mech ]
 
448
                    ~time_rec:`Indefinite
 
449
                    ~minor_status:0l
 
450
                    ~major_status:(`None,`None,[])
 
451
                    ()
 
452
                with
 
453
                  | Not_found -> error `No_cred in
 
454
              (* Expect nt_user_name: *)
 
455
              if desired_name # name_type = Netgssapi.nt_user_name then (
 
456
                let user = desired_name # name_string in
 
457
                out_client_cred user
 
458
              )
 
459
              else (
 
460
                if desired_name = no_name then (
 
461
                  (* maybe we have a default: *)
 
462
                  match client_key_ring # default_user_name with
 
463
                    | None -> error `No_cred
 
464
                    | Some user -> out_client_cred user
 
465
                )               
 
466
                else
 
467
                  error `Bad_nametype
 
468
              )
 
469
            )
 
470
            else
 
471
              error `Bad_mech
 
472
        | `Accept ->
 
473
            (* For server: Effectively there are no credentials. So we accept
 
474
               any desired_name.
 
475
             *)
 
476
            if List.mem scram_mech desired_mechs then (
 
477
              let server_name =
 
478
                new scram_name "@" nt_hostbased_service  in
 
479
              NameBCT.store names server_name;
 
480
              let cred =
 
481
                new scram_cred (server_name :> name) Cred_server in
 
482
              CredentialBCT.store credentials cred;
 
483
              out
 
484
                ~cred:(cred :> credential) 
 
485
                ~actual_mechs:[ scram_mech ]
 
486
                ~time_rec:`Indefinite
 
487
                ~minor_status:0l
 
488
                ~major_status:(`None,`None,[])
 
489
                ()
 
490
            )
 
491
            else
 
492
              error `Bad_mech
 
493
        | `Both ->
 
494
            (* Not supported - credentials are either for the client or
 
495
               for the server
 
496
             *)
 
497
            out
 
498
              ~cred:no_cred_out ~actual_mechs:[] ~time_rec:`Indefinite
 
499
              ~minor_status:0l ~major_status:(`None,`Bad_nametype,[]) ()
 
500
              
 
501
  method add_cred :
 
502
          't . input_cred:credential ->
 
503
               desired_name:name ->
 
504
               desired_mech:oid ->
 
505
               cred_usage:cred_usage ->
 
506
               initiator_time_req:[`None | `Indefinite | `This of float] ->
 
507
               acceptor_time_req:[`None | `Indefinite | `This of float] ->
 
508
               out:( output_cred:credential ->
 
509
                     actual_mechs:oid_set ->
 
510
                     initiator_time_rec:[ `Indefinite | `This of float] ->
 
511
                     acceptor_time_rec:[ `Indefinite | `This of float] ->
 
512
                     minor_status:minor_status ->
 
513
                     major_status:major_status ->
 
514
                     unit ->
 
515
                     't
 
516
                   ) -> unit -> 't =
 
517
    fun ~input_cred ~desired_name ~desired_mech ~cred_usage 
 
518
        ~initiator_time_req ~acceptor_time_req ~out () 
 
519
      ->
 
520
        (* More or less it is not possible to add to credentials - we have
 
521
           here only one mechanism. So, the only thing to do here is to
 
522
           create the right error message.
 
523
         *)
 
524
        let error code =
 
525
          out
 
526
            ~output_cred:no_cred_out ~actual_mechs:[] 
 
527
            ~initiator_time_rec:`Indefinite ~acceptor_time_rec:`Indefinite
 
528
            ~minor_status:0l ~major_status:(`None,code,[]) () in
 
529
        let input_cred = cred_retrieve input_cred in
 
530
        let desired_name = name_retrieve desired_name in
 
531
        let add cred =
 
532
          if scram_mech = desired_mech then
 
533
            error `Duplicate_element
 
534
          else
 
535
            error `Bad_mech in
 
536
        if input_cred = no_cred then (
 
537
          self # acquire_cred 
 
538
            ~desired_name:(desired_name :> name)
 
539
            ~time_req:`None ~desired_mechs:[desired_mech] ~cred_usage
 
540
            ~out:(
 
541
              fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status() ->
 
542
                let (_,code,_) = major_status in
 
543
                if code = `None then add cred else error code
 
544
            )
 
545
            ()
 
546
        ) else
 
547
          add input_cred
 
548
            
 
549
  method canonicalize_name :
 
550
          't . input_name:name ->
 
551
               mech_type:oid ->
 
552
               out:( output_name:name ->
 
553
                     minor_status:minor_status ->
 
554
                     major_status:major_status ->
 
555
                     unit ->
 
556
                     't
 
557
                   ) -> unit -> 't =
 
558
    fun ~input_name ~mech_type ~out () ->
 
559
      let error code =
 
560
        out 
 
561
          ~output_name:no_name_out ~minor_status:0l
 
562
          ~major_status:(`None,code,[]) ()
 
563
      in
 
564
      let input_name = name_retrieve input_name in
 
565
      if mech_type <> scram_mech then
 
566
        error `Bad_mech
 
567
      else
 
568
        out
 
569
          ~output_name:(input_name :> name) ~minor_status:0l
 
570
          ~major_status:(`None,`None,[]) ()
 
571
 
 
572
  method compare_name :
 
573
          't . name1:name ->
 
574
               name2:name ->
 
575
               out:( name_equal:bool ->
 
576
                     minor_status:minor_status ->
 
577
                     major_status:major_status ->
 
578
                     unit ->
 
579
                     't
 
580
                   ) -> unit -> 't =
 
581
    fun ~name1 ~name2 ~out () ->
 
582
      let name1 = name_retrieve name1 in
 
583
      let name2 = name_retrieve name2 in
 
584
      let equal =
 
585
        name1 # name_type <> nt_anonymous &&
 
586
          name2 # name_type <> nt_anonymous &&
 
587
          (name1 = name2 || 
 
588
              (name1#name_type = name2#name_type && 
 
589
                  name1#name_string = name2#name_string)) in
 
590
      out ~name_equal:equal ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
591
        
 
592
  method context_time :
 
593
          't . context:context ->
 
594
               out:( time_rec:[ `Indefinite | `This of float] ->
 
595
                     minor_status:minor_status ->
 
596
                     major_status:major_status ->
 
597
                     unit ->
 
598
                     't
 
599
                   ) -> unit -> 't =
 
600
    fun ~context ~out () ->
 
601
      let context = context_retrieve context in
 
602
      if not context#valid then
 
603
        out ~time_rec:`Indefinite ~minor_status:0l
 
604
          ~major_status:(`None,`No_context,[]) ()
 
605
      else
 
606
        out
 
607
          ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[])
 
608
          ()
 
609
 
 
610
  method delete_sec_context :
 
611
          't . context:context ->
 
612
               out:( minor_status:minor_status ->
 
613
                     major_status:major_status ->
 
614
                     unit ->
 
615
                     't
 
616
                   ) -> unit -> 't =
 
617
    fun ~context ~out () ->
 
618
      let context = context_retrieve context in
 
619
      context#delete();
 
620
      out ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
621
        
 
622
  method display_name :
 
623
          't . input_name:name ->
 
624
               out:( output_name:string ->
 
625
                     output_name_type:oid ->
 
626
                     minor_status:minor_status ->
 
627
                     major_status:major_status ->
 
628
                     unit ->
 
629
                     't
 
630
                   ) -> unit -> 't =
 
631
    fun ~input_name ~out () ->
 
632
      (* We just return the name_string *)
 
633
      let input_name = name_retrieve input_name in
 
634
      out
 
635
        ~output_name:input_name#name_string
 
636
        ~output_name_type:input_name#name_type
 
637
        ~minor_status:0l
 
638
        ~major_status:(`None,`None,[])
 
639
        ()
 
640
 
 
641
  method display_minor_status :
 
642
          't . minor_status:minor_status ->
 
643
               mech_type: oid ->
 
644
               out:( status_strings: string list ->
 
645
                     minor_status:minor_status ->
 
646
                     major_status:major_status ->
 
647
                     unit ->
 
648
                     't
 
649
                   ) -> unit -> 't =
 
650
    fun ~minor_status ~mech_type ~out ()  ->
 
651
      out
 
652
        ~status_strings:["<minor>"] 
 
653
        ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
654
        
 
655
  method export_name :
 
656
          't . name:name ->
 
657
               out:( exported_name:string ->
 
658
                     minor_status:minor_status ->
 
659
                     major_status:major_status ->
 
660
                     unit ->
 
661
                     't
 
662
                   ) -> unit -> 't =
 
663
    fun ~name ~out () ->
 
664
      let name = name_retrieve name in
 
665
      let s1 =
 
666
        encode_exported_name name#name_type name#name_string in
 
667
      let s2 =
 
668
      encode_exported_name scram_mech s1 in
 
669
      out
 
670
        ~exported_name:s2
 
671
        ~minor_status:0l
 
672
        ~major_status:(`None,`None,[])
 
673
        ()
 
674
 
 
675
  method export_sec_context :
 
676
          't . context:context ->
 
677
               out:( interprocess_token:interprocess_token ->
 
678
                     minor_status:minor_status ->
 
679
                     major_status:major_status ->
 
680
                     unit ->
 
681
                     't
 
682
                   ) -> unit -> 't =
 
683
    fun ~context ~out () ->
 
684
      (* FIXME: Maybe we should also export the seq_nr *)
 
685
      let context = context_retrieve context in
 
686
      if not context#valid then
 
687
        out
 
688
          ~interprocess_token:"" ~minor_status:0l
 
689
          ~major_status:(`None,`No_context,[]) ()
 
690
      else (
 
691
        try
 
692
          let interprocess_token =
 
693
            match context#ctx with
 
694
              | Ctx_client sess ->
 
695
                  "C" ^ Netmech_scram.client_export sess
 
696
              | Ctx_server sess ->
 
697
                  "S" ^ Netmech_scram.server_export sess in
 
698
          out
 
699
            ~interprocess_token ~minor_status:0l
 
700
            ~major_status:(`None,`None,[]) ()
 
701
        with
 
702
          | Failure _ ->
 
703
              out
 
704
                ~interprocess_token:"" ~minor_status:0l
 
705
                ~major_status:(`None,`Unavailable,[]) ()
 
706
      )
 
707
 
 
708
 
 
709
  method get_mic :
 
710
          't . context:context ->
 
711
               qop_req:qop option ->
 
712
               message:message ->
 
713
               out:( msg_token:token ->
 
714
                     minor_status:minor_status ->
 
715
                     major_status:major_status ->
 
716
                     unit ->
 
717
                     't
 
718
                   ) -> unit -> 't =
 
719
    fun ~context ~qop_req ~message ~out () ->
 
720
      let context = context_retrieve context in
 
721
      if not context#valid then
 
722
        out
 
723
          ~msg_token:"" ~minor_status:0l
 
724
          ~major_status:(`None,`No_context,[]) ()
 
725
      else (
 
726
        (* Reject any QOP: *)
 
727
        if qop_req <> None && qop_req <> Some default_qop then
 
728
          out
 
729
            ~msg_token:"" ~minor_status:0l
 
730
            ~major_status:(`None,`Bad_QOP,[]) ()
 
731
        else (
 
732
          let sk_opt = context # specific_keys in
 
733
          match sk_opt with
 
734
            | None ->
 
735
                out
 
736
                  ~msg_token:"" ~minor_status:0l
 
737
                  ~major_status:(`None,`No_context,[]) ()
 
738
            | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
 
739
                let sk_mic =
 
740
                  if context#is_acceptor then k_mic_s else k_mic_c in
 
741
                let sequence_number = context # seq_nr in
 
742
                let sent_by_acceptor = context # is_acceptor in
 
743
                let token =
 
744
                  Netgssapi.create_mic_token
 
745
                    ~sent_by_acceptor
 
746
                    ~acceptor_subkey:false
 
747
                    ~sequence_number
 
748
                    ~get_mic:(
 
749
                      Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic)
 
750
                    ~message in
 
751
                out
 
752
                  ~msg_token:token ~minor_status:0l
 
753
                  ~major_status:(`None,`None,[])
 
754
                  ()
 
755
        )
 
756
      )
 
757
        
 
758
  method import_name :
 
759
          't . input_name:string ->
 
760
               input_name_type:oid ->
 
761
               out:( output_name:name ->
 
762
                     minor_status:minor_status ->
 
763
                     major_status:major_status ->
 
764
                     unit ->
 
765
                     't
 
766
                   ) -> unit -> 't =
 
767
    fun ~input_name ~input_name_type ~out () ->
 
768
      let out_name name_string name_type =
 
769
        let n = new scram_name name_string name_type in
 
770
        NameBCT.store names n;
 
771
        out
 
772
          ~output_name:(n :> name)
 
773
          ~minor_status:0l 
 
774
          ~major_status:(`None,`None,[])
 
775
          () in
 
776
      if input_name_type = nt_hostbased_service then
 
777
        try
 
778
          let (_service,_host) = parse_hostbased_service input_name in
 
779
          out_name input_name nt_hostbased_service
 
780
        with
 
781
          | _ ->
 
782
              out
 
783
                ~output_name:no_name_out ~minor_status:0l 
 
784
                ~major_status:(`None,`Bad_name,[]) ()
 
785
      else
 
786
        if input_name_type = nt_user_name then
 
787
          out_name input_name nt_user_name
 
788
        else
 
789
          if input_name_type = nt_export_name then
 
790
            try
 
791
              let k = ref 0 in
 
792
              let (mech_oid,s1) = decode_exported_name input_name k in
 
793
              if !k <> String.length input_name then failwith "too short";
 
794
              if mech_oid <> scram_mech then 
 
795
                out
 
796
                  ~output_name:no_name_out ~minor_status:0l 
 
797
                  ~major_status:(`None,`Bad_name,[]) ()
 
798
              else (
 
799
                k := 0;
 
800
                let (name_oid,s2) = decode_exported_name s1 k in
 
801
                if !k <> String.length input_name then failwith "too short";
 
802
                out_name s2 name_oid
 
803
              )
 
804
            with
 
805
              | Failure _ ->
 
806
                  out
 
807
                    ~output_name:no_name_out ~minor_status:0l 
 
808
                    ~major_status:(`None,`Bad_name,[]) ()
 
809
          else
 
810
            if input_name_type = [||] then
 
811
              out_name input_name nt_user_name
 
812
            else
 
813
              out
 
814
                ~output_name:no_name_out
 
815
                ~minor_status:0l 
 
816
                ~major_status:(`None,`Bad_nametype,[])
 
817
                () 
 
818
              
 
819
                
 
820
 
 
821
  method import_sec_context :
 
822
          't . interprocess_token:interprocess_token ->
 
823
               out:( context:context option ->
 
824
                     minor_status:minor_status ->
 
825
                     major_status:major_status ->
 
826
                     unit ->
 
827
                     't
 
828
                   ) -> unit -> 't =
 
829
    fun ~interprocess_token ~out () ->
 
830
      let error code =
 
831
        out ~context:None ~minor_status:0l ~major_status:(`None,code,[]) () in
 
832
      let l = String.length interprocess_token in
 
833
      if interprocess_token = "" then
 
834
        error `Defective_token
 
835
      else
 
836
        match interprocess_token.[0] with
 
837
          | 'C' ->
 
838
              let t = String.sub interprocess_token 1 (l-1) in
 
839
              let sess =
 
840
                Netmech_scram.client_import t in
 
841
              let context = 
 
842
                new scram_context (Ctx_client sess) scram_ret_flags in
 
843
              ContextBCT.store contexts context;
 
844
              out
 
845
                ~context:(Some (context :> context)) 
 
846
                ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
847
          | 'S' ->
 
848
              let t = String.sub interprocess_token 1 (l-1) in
 
849
              let sess =
 
850
                Netmech_scram.server_import t in
 
851
              let context = 
 
852
                new scram_context (Ctx_server sess) scram_ret_flags in
 
853
              ContextBCT.store contexts context;
 
854
              out
 
855
                ~context:(Some (context :> context)) 
 
856
                ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
857
          | _ ->
 
858
              error `Defective_token
 
859
                
 
860
  method indicate_mechs :
 
861
          't . out:( mech_set:oid_set ->
 
862
                     minor_status:minor_status ->
 
863
                     major_status:major_status ->
 
864
                     unit ->
 
865
                     't
 
866
                   ) -> unit -> 't =
 
867
    fun ~out () ->
 
868
      out 
 
869
        ~mech_set:[ scram_mech ]
 
870
        ~minor_status:0l
 
871
        ~major_status:(`None, `None, [])
 
872
        ()
 
873
 
 
874
  method init_sec_context :
 
875
          't . initiator_cred:credential ->
 
876
               context:context option ->
 
877
               target_name:name ->
 
878
               mech_type:oid -> 
 
879
               req_flags:req_flag list ->
 
880
               time_rec:float option ->
 
881
               chan_bindings:channel_bindings option ->
 
882
               input_token:token option ->
 
883
               out:( actual_mech_type:oid ->
 
884
                     output_context:context option ->
 
885
                     output_token:token ->
 
886
                     ret_flags:ret_flag list ->
 
887
                     time_rec:[ `Indefinite | `This of float ] ->
 
888
                     minor_status:minor_status ->
 
889
                     major_status:major_status ->
 
890
                     unit ->
 
891
                     't
 
892
                   ) -> unit -> 't =
 
893
    fun
 
894
          ~initiator_cred ~context ~target_name ~mech_type ~req_flags
 
895
          ~time_rec ~chan_bindings ~input_token ~out () ->
 
896
    let actual_mech_type = scram_mech in
 
897
    try
 
898
      let cb_data =
 
899
        match chan_bindings with
 
900
          | None -> ""
 
901
          | Some (init_addr, acc_addr, cb_data) -> cb_data in
 
902
      (* We ignore init_addr and acc_addr... CHECK *)
 
903
      let initiator_cred =
 
904
        cred_retrieve initiator_cred in
 
905
      let eff_init_cred =
 
906
        if initiator_cred = no_cred then
 
907
          try self # get_default_client_cred()
 
908
          with
 
909
            | Not_found ->
 
910
                raise(Routine_error `No_cred);  (* No default *)
 
911
        else
 
912
          initiator_cred in
 
913
      let user, pw =
 
914
        match eff_init_cred # cred with
 
915
          | Cred_client(user,pw) -> (user,pw)
 
916
          | _ ->
 
917
              raise(Routine_error `No_cred) in
 
918
      let context, sess, continuation =
 
919
        match context with
 
920
          | None ->
 
921
              let sess =
 
922
                Netmech_scram.create_client_session
 
923
                  profile user pw in
 
924
              let ctx =
 
925
                Ctx_client sess in
 
926
              let context = new scram_context ctx scram_ret_flags in
 
927
              (context # server_cb) := cb_data;
 
928
              ContextBCT.store contexts context;
 
929
              (context, sess, false)
 
930
          | Some c -> 
 
931
              let context = context_retrieve c in
 
932
              if not context#valid then
 
933
                raise(Routine_error `No_context);
 
934
              let sess =
 
935
                match context#ctx with
 
936
                  | Ctx_client sess -> sess
 
937
                  | Ctx_server _ -> raise (Routine_error `No_context) in
 
938
              (context, sess, true) in
 
939
      if mech_type <> [||] && mech_type <> scram_mech then
 
940
        raise(Routine_error `Bad_mech);
 
941
      (*
 
942
        if List.mem `Deleg_flag req_flags then XXX;
 
943
        if List.mem `Anon_flag req_flags then XXX;
 
944
       *)
 
945
      (* Note that we ignore target_name entirely. It is not needed for
 
946
         SCRAM.
 
947
       *)
 
948
      if continuation then (  (* this may raise exceptions *)
 
949
        try
 
950
          match input_token with
 
951
            | Some intok ->
 
952
                Netmech_scram.client_recv_message sess intok
 
953
            | None ->
 
954
                raise(Calling_error `Bad_structure)
 
955
        with
 
956
          | Netmech_scram.Invalid_encoding(_,_) ->
 
957
              raise(Routine_error `Defective_token)
 
958
          | Netmech_scram.Invalid_username_encoding(_,_) ->
 
959
              raise(Routine_error `Defective_token)
 
960
          | Netmech_scram.Extensions_not_supported(_,_) ->
 
961
              raise(Routine_error `Failure)
 
962
          | Netmech_scram.Protocol_error _ ->
 
963
              raise(Routine_error `Failure)
 
964
          | Netmech_scram.Invalid_server_signature ->
 
965
              raise(Routine_error `Bad_mic)
 
966
          | Netmech_scram.Server_error e ->
 
967
              ( match e with
 
968
                  | `Invalid_encoding
 
969
                  | `Extensions_not_supported
 
970
                  | `Invalid_proof
 
971
                  | `Channel_bindings_dont_match
 
972
                  | `Server_does_support_channel_binding
 
973
                  | `Channel_binding_not_supported
 
974
                  | `Unsupported_channel_binding_type
 
975
                  | `Unknown_user
 
976
                  | `Invalid_username_encoding
 
977
                  | `No_resources
 
978
                  | `Other_error
 
979
                  | `Extension _ ->
 
980
                      raise(Routine_error `Failure)
 
981
              )
 
982
      );
 
983
      if Netmech_scram.client_finish_flag sess then (
 
984
        let ret_flags =
 
985
          [`Trans_flag; `Prot_ready_flag ] @ scram_ret_flags in
 
986
        context # flags := ret_flags;
 
987
        out
 
988
          ~actual_mech_type ~output_context:(Some (context :> context))
 
989
          ~output_token:""
 
990
          ~ret_flags
 
991
          ~time_rec:`Indefinite ~minor_status:0l
 
992
          ~major_status:(`None,`None,[]) ()
 
993
      )
 
994
      else (
 
995
        let output_token_1 =
 
996
          Netmech_scram.client_emit_message sess in
 
997
        let output_token =
 
998
          if continuation then
 
999
            output_token_1
 
1000
          else
 
1001
            Netgssapi.wire_encode_token scram_mech output_token_1 in
 
1002
        let ret_flags =
 
1003
          if Netmech_scram.client_protocol_key sess <> None then
 
1004
            `Prot_ready_flag :: scram_ret_flags
 
1005
          else
 
1006
            scram_ret_flags in
 
1007
        context # flags := ret_flags;
 
1008
        out
 
1009
          ~actual_mech_type ~output_context:(Some (context :> context))
 
1010
          ~output_token ~ret_flags
 
1011
          ~time_rec:`Indefinite ~minor_status:0l
 
1012
          ~major_status:(`None,`None,[`Continue_needed]) ()
 
1013
      )
 
1014
    with
 
1015
      | Calling_error code ->
 
1016
          out
 
1017
          ~actual_mech_type  ~output_context:None
 
1018
            ~output_token:"" ~ret_flags:scram_ret_flags
 
1019
          ~time_rec:`Indefinite ~minor_status:0l
 
1020
          ~major_status:(code,`None,[]) ()
 
1021
      | Routine_error code ->
 
1022
          out
 
1023
          ~actual_mech_type ~output_context:None
 
1024
            ~output_token:"" ~ret_flags:scram_ret_flags
 
1025
          ~time_rec:`Indefinite ~minor_status:0l
 
1026
          ~major_status:(`None,code,[]) ()
 
1027
 
 
1028
  method inquire_context :
 
1029
          't . context:context ->
 
1030
               out:( src_name:name ->
 
1031
                     targ_name:name ->
 
1032
                     lifetime_req : [ `Indefinite | `This of float ] ->
 
1033
                     mech_type:oid ->
 
1034
                     ctx_flags:ret_flag list ->
 
1035
                     locally_initiated:bool ->
 
1036
                     is_open:bool ->
 
1037
                     minor_status:minor_status ->
 
1038
                     major_status:major_status ->
 
1039
                     unit ->
 
1040
                     't
 
1041
                   ) -> unit -> 't =
 
1042
    fun
 
1043
      ~context ~out () ->
 
1044
    let error code =
 
1045
      out
 
1046
        ~src_name:no_name_out ~targ_name:no_name_out ~lifetime_req:`Indefinite
 
1047
        ~mech_type:scram_mech ~ctx_flags:scram_ret_flags 
 
1048
        ~locally_initiated:false ~is_open:false 
 
1049
        ~minor_status:0l ~major_status:(`None, code, []) () in
 
1050
    let context = context_retrieve context in
 
1051
    if context # valid then
 
1052
      match context # ctx with
 
1053
        | Ctx_client sess ->
 
1054
            let src_name =
 
1055
              new scram_name
 
1056
                (Netmech_scram.client_user_name sess) nt_user_name in
 
1057
            NameBCT.store names src_name;
 
1058
            let src_name = (src_name :> name) in
 
1059
            let targ_name =
 
1060
              new scram_name "@" nt_hostbased_service in
 
1061
            NameBCT.store names targ_name;
 
1062
            let targ_name = (targ_name :> name) in
 
1063
            let is_open = Netmech_scram.client_finish_flag sess in
 
1064
            out
 
1065
              ~src_name ~targ_name ~lifetime_req:`Indefinite
 
1066
              ~mech_type:scram_mech ~ctx_flags:!(context # flags)
 
1067
              ~locally_initiated:true ~is_open
 
1068
              ~minor_status:0l ~major_status:(`None, `None, []) ()
 
1069
              
 
1070
        | Ctx_server sess ->
 
1071
            let src_name =
 
1072
              match Netmech_scram.server_user_name sess with
 
1073
                | None ->
 
1074
                    no_name
 
1075
                | Some u ->
 
1076
                    new scram_name u nt_user_name in
 
1077
            NameBCT.store names src_name;
 
1078
            let src_name = (src_name :> name) in
 
1079
            let targ_name =
 
1080
              new scram_name "@" nt_hostbased_service in
 
1081
            NameBCT.store names targ_name;
 
1082
            let targ_name = (targ_name :> name) in
 
1083
            let is_open = Netmech_scram.server_finish_flag sess in
 
1084
            out
 
1085
              ~src_name ~targ_name ~lifetime_req:`Indefinite
 
1086
              ~mech_type:scram_mech ~ctx_flags:!(context # flags)
 
1087
              ~locally_initiated:true ~is_open
 
1088
              ~minor_status:0l ~major_status:(`None, `None, []) ()
 
1089
    else
 
1090
      error `No_context
 
1091
 
 
1092
 
 
1093
  method inquire_cred :
 
1094
          't . cred:credential ->
 
1095
               out:( name:name ->
 
1096
                     lifetime: [ `Indefinite | `This of float ] ->
 
1097
                     cred_usage:cred_usage ->
 
1098
                     mechanisms:oid_set ->
 
1099
                     minor_status:minor_status ->
 
1100
                     major_status:major_status ->
 
1101
                     unit ->
 
1102
                     't
 
1103
                   ) -> unit -> 't = fun ~cred ~out () ->
 
1104
    let cred = cred_retrieve cred in
 
1105
    let eff_cred =
 
1106
      if cred = no_cred then
 
1107
        try
 
1108
          self # get_default_client_cred()
 
1109
        with
 
1110
          | Not_found -> no_cred
 
1111
              (* We do not support a default initiator credential *)
 
1112
      else
 
1113
        cred in
 
1114
    if eff_cred = no_cred then
 
1115
      out
 
1116
        ~name:no_name_out
 
1117
        ~lifetime:`Indefinite
 
1118
        ~cred_usage:`Initiate
 
1119
        ~mechanisms:[]
 
1120
        ~minor_status:0l
 
1121
        ~major_status:(`None, `No_cred, [])
 
1122
        ()
 
1123
    else
 
1124
      out
 
1125
        ~name:eff_cred#name
 
1126
        ~lifetime:`Indefinite
 
1127
        ~cred_usage:( match eff_cred#cred with
 
1128
                        | Cred_server -> `Accept
 
1129
                        | Cred_client _ -> `Initiate
 
1130
                        | _ -> assert false
 
1131
                    )
 
1132
        ~mechanisms:[ scram_mech ]
 
1133
        ~minor_status:0l
 
1134
        ~major_status:(`None, `None, [])
 
1135
        ()
 
1136
        
 
1137
  method inquire_cred_by_mech :
 
1138
          't . cred:credential ->
 
1139
               mech_type:oid -> 
 
1140
               out:( name:name ->
 
1141
                     initiator_lifetime: [ `Indefinite | `This of float ] ->
 
1142
                     acceptor_lifetime: [ `Indefinite | `This of float ] ->
 
1143
                     cred_usage:cred_usage ->
 
1144
                     minor_status:minor_status ->
 
1145
                     major_status:major_status ->
 
1146
                     unit ->
 
1147
                     't
 
1148
                   ) -> unit -> 't =
 
1149
    fun
 
1150
      ~cred ~mech_type ~out () ->
 
1151
    let cred = cred_retrieve cred in
 
1152
    let error code =
 
1153
      out
 
1154
        ~name:no_name_out ~initiator_lifetime:`Indefinite 
 
1155
        ~acceptor_lifetime:`Indefinite ~cred_usage:`Initiate
 
1156
        ~minor_status:0l ~major_status:(`None,code,[]) () in
 
1157
    if mech_type <> scram_mech then
 
1158
      error `Bad_mech
 
1159
        (* CHECK: not documented in RFC 2744 for this function *)
 
1160
    else
 
1161
      let eff_cred_opt =
 
1162
        if cred = no_cred then
 
1163
          try Some(self # get_default_client_cred())
 
1164
          with Not_found -> None
 
1165
        else
 
1166
          Some cred in
 
1167
      match eff_cred_opt with
 
1168
        | Some eff_cred ->
 
1169
            out
 
1170
              ~name:eff_cred#name
 
1171
              ~initiator_lifetime:`Indefinite
 
1172
              ~acceptor_lifetime:`Indefinite
 
1173
              ~cred_usage:( match eff_cred#cred with
 
1174
                              | Cred_server -> `Accept
 
1175
                              | Cred_client _ -> `Initiate
 
1176
                              | _ -> assert false
 
1177
                          )
 
1178
              ~minor_status:0l
 
1179
              ~major_status:(`None, `None, [])
 
1180
              ()
 
1181
        | None ->
 
1182
            error `No_cred  (* No default initiator credentials *)
 
1183
        
 
1184
  method inquire_mechs_for_name :
 
1185
          't . name:name ->
 
1186
               out:( mech_types:oid_set ->
 
1187
                     minor_status:minor_status ->
 
1188
                     major_status:major_status ->
 
1189
                     unit ->
 
1190
                     't
 
1191
                   ) -> unit -> 't =
 
1192
    fun ~name ~out () ->
 
1193
    let name = name_retrieve name in
 
1194
    let l =
 
1195
      if name#name_type = nt_hostbased_service ||
 
1196
        name#name_type = nt_user_name
 
1197
      then
 
1198
        [ scram_mech ]
 
1199
      else
 
1200
        [] in
 
1201
    out
 
1202
      ~mech_types:l ~minor_status:0l ~major_status:(`None,`None,[]) ()
 
1203
 
 
1204
  method inquire_names_for_mech :
 
1205
          't . mechanism:oid ->
 
1206
               out:( name_types:oid_set ->
 
1207
                     minor_status:minor_status ->
 
1208
                     major_status:major_status ->
 
1209
                     unit ->
 
1210
                     't
 
1211
                   ) -> unit -> 't =
 
1212
    fun ~mechanism ~out () ->
 
1213
    let l =
 
1214
      if mechanism = scram_mech then 
 
1215
        [ nt_hostbased_service; nt_user_name ]
 
1216
      else
 
1217
        [] in
 
1218
    out 
 
1219
      ~name_types:l
 
1220
      ~minor_status:0l
 
1221
      ~major_status:(`None, `None, [])
 
1222
      ()
 
1223
 
 
1224
  method process_context_token :
 
1225
          't . context:context ->
 
1226
               token:token ->
 
1227
               out:( minor_status:minor_status ->
 
1228
                     major_status:major_status ->
 
1229
                     unit ->
 
1230
                     't
 
1231
                   ) -> unit -> 't =
 
1232
    fun ~context ~token ~out () ->
 
1233
    (* There are no context tokens... *)
 
1234
    let _context = context_retrieve context in
 
1235
    out ~minor_status:0l ~major_status:(`None,`Defective_token,[]) ()
 
1236
 
 
1237
  method unwrap :
 
1238
          't . context:context ->
 
1239
               input_message:message ->
 
1240
               output_message_preferred_type:[ `String | `Memory ] ->
 
1241
               out:( output_message:message ->
 
1242
                     conf_state:bool ->
 
1243
                     qop_state:qop ->
 
1244
                     minor_status:minor_status ->
 
1245
                     major_status:major_status ->
 
1246
                     unit ->
 
1247
                     't
 
1248
                   ) -> unit -> 't =
 
1249
    fun  ~context ~input_message ~output_message_preferred_type ~out
 
1250
      () ->
 
1251
    let context = context_retrieve context in
 
1252
    let sk_opt = context # specific_keys in
 
1253
    let error code =
 
1254
      out
 
1255
        ~output_message:[] ~conf_state:false ~qop_state:default_qop
 
1256
        ~minor_status:0l ~major_status:(`None,code,[]) () in
 
1257
    if not context#valid then
 
1258
      error `No_context
 
1259
    else
 
1260
      match sk_opt with
 
1261
        | None ->
 
1262
            error `No_context
 
1263
        | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
 
1264
            let sk_wrap =
 
1265
              if context#is_acceptor then k_wrap_c else k_wrap_s in
 
1266
            ( try
 
1267
                let (sent_by_acceptor, _, _, tok_seq_nr) =
 
1268
                  Netgssapi.parse_wrap_token_header input_message in
 
1269
                if sent_by_acceptor = context#is_acceptor then
 
1270
                  raise Netmech_scram.Cryptosystem.Integrity_error;
 
1271
                let flags = context#is_peer_seq_nr_ok tok_seq_nr in
 
1272
                let s =
 
1273
                  Netgssapi.unwrap_wrap_token_conf
 
1274
                    ~decrypt_and_verify:(
 
1275
                      Netmech_scram.Cryptosystem.decrypt_and_verify_mstrings
 
1276
                        sk_wrap)
 
1277
                    ~token:input_message in
 
1278
                out
 
1279
                  ~output_message:s
 
1280
                  ~conf_state:true
 
1281
                  ~qop_state:default_qop
 
1282
                  ~minor_status:0l ~major_status:(`None,`None,flags) ()
 
1283
              with
 
1284
                | Netmech_scram.Cryptosystem.Integrity_error ->
 
1285
                    error `Bad_mic
 
1286
                | _ -> (* probable Invalid_argument *)
 
1287
                    error `Defective_token
 
1288
            )
 
1289
 
 
1290
 
 
1291
  method verify_mic :
 
1292
          't . context:context ->
 
1293
               message:message ->
 
1294
               token:token ->
 
1295
               out:( qop_state:qop ->
 
1296
                     minor_status:minor_status ->
 
1297
                     major_status:major_status ->
 
1298
                     unit ->
 
1299
                     't
 
1300
                   ) -> unit -> 't =
 
1301
    fun ~context ~message ~token ~out () ->
 
1302
    let context = context_retrieve context in
 
1303
    let sk_opt = context # specific_keys in
 
1304
    if not context#valid then
 
1305
      out
 
1306
        ~qop_state:default_qop ~minor_status:0l
 
1307
        ~major_status:(`None,`No_context,[]) ()
 
1308
    else
 
1309
      match sk_opt with
 
1310
        | None ->
 
1311
            out
 
1312
              ~qop_state:default_qop ~minor_status:0l
 
1313
              ~major_status:(`None,`No_context,[]) ()
 
1314
        | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
 
1315
            let sk_mic =
 
1316
              if context#is_acceptor then k_mic_c else k_mic_s in
 
1317
            let (sent_by_acceptor,_,tok_seq_nr) =
 
1318
              Netgssapi.parse_mic_token_header token in
 
1319
            let flags =
 
1320
              context#is_peer_seq_nr_ok tok_seq_nr in
 
1321
            let ok =
 
1322
              sent_by_acceptor <> context#is_acceptor &&
 
1323
                (Netgssapi.verify_mic_token
 
1324
                   ~get_mic:(Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic)
 
1325
                   ~message
 
1326
                   ~token) in
 
1327
            if ok then
 
1328
              out
 
1329
                ~qop_state:default_qop ~minor_status:0l
 
1330
                ~major_status:(`None,`None,flags) ()
 
1331
            else
 
1332
              out
 
1333
                ~qop_state:default_qop ~minor_status:0l
 
1334
                ~major_status:(`None,`Bad_mic,[]) ()
 
1335
      
 
1336
  method wrap :
 
1337
          't . context:context ->
 
1338
               conf_req:bool ->
 
1339
               qop_req:qop option ->
 
1340
               input_message:message ->
 
1341
               output_message_preferred_type:[ `String | `Memory ] ->
 
1342
               out:( conf_state:bool ->
 
1343
                     output_message:message ->
 
1344
                     minor_status:minor_status ->
 
1345
                     major_status:major_status ->
 
1346
                     unit ->
 
1347
                     't
 
1348
                   ) -> unit -> 't =
 
1349
    fun
 
1350
          ~context ~conf_req ~qop_req ~input_message 
 
1351
          ~output_message_preferred_type ~out () ->
 
1352
    let context = context_retrieve context in
 
1353
    if not context#valid then
 
1354
      out
 
1355
        ~conf_state:false ~output_message:[] ~minor_status:0l
 
1356
        ~major_status:(`None,`No_context,[]) ()
 
1357
    else
 
1358
      let sk_opt = context # specific_keys in
 
1359
      (* Reject any QOP: *)
 
1360
      if qop_req <> None && qop_req <> Some default_qop then
 
1361
        out
 
1362
          ~conf_state:false ~output_message:[] ~minor_status:0l
 
1363
          ~major_status:(`None,`Bad_QOP,[]) ()
 
1364
      else (
 
1365
        match sk_opt with
 
1366
          | None ->
 
1367
              out
 
1368
                ~conf_state:false ~output_message:[] ~minor_status:0l
 
1369
                ~major_status:(`None,`No_context,[]) ()
 
1370
          | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) ->
 
1371
              let sk_wrap =
 
1372
                if context#is_acceptor then k_wrap_s else k_wrap_c in
 
1373
              let token =
 
1374
                Netgssapi.create_wrap_token_conf
 
1375
                  ~sent_by_acceptor:context#is_acceptor
 
1376
                  ~acceptor_subkey:false
 
1377
                  ~sequence_number:context#seq_nr
 
1378
                  ~get_ec:(
 
1379
                    Netmech_scram.Cryptosystem.get_ec sk_wrap)
 
1380
                  ~encrypt_and_sign:(
 
1381
                    Netmech_scram.Cryptosystem.encrypt_and_sign_mstrings
 
1382
                      sk_wrap)
 
1383
                  ~message:input_message in
 
1384
              out
 
1385
                ~conf_state:true 
 
1386
                ~output_message:token
 
1387
                ~minor_status:0l
 
1388
                ~major_status:(`None,`None,[])
 
1389
                ()
 
1390
      )
 
1391
        
 
1392
 
 
1393
  method wrap_size_limit :
 
1394
          't . context:context ->
 
1395
               conf_req:bool ->
 
1396
               qop_req:qop option ->
 
1397
               req_output_size:int ->
 
1398
               out:( max_input_size:int ->
 
1399
                     minor_status:minor_status ->
 
1400
                     major_status:major_status ->
 
1401
                     unit ->
 
1402
                     't
 
1403
                   ) -> unit -> 't =
 
1404
    fun ~context ~conf_req ~qop_req ~req_output_size ~out () ->
 
1405
    let _context = context_retrieve context in
 
1406
 
 
1407
    (* We have:
 
1408
       - 12 bytes for the MIC
 
1409
       - the message is padded to a multiple of 16 bytes
 
1410
       - the message includes a 16 bytes random header
 
1411
     *)
 
1412
    let p_size = (req_output_size - 12) / 16 * 16 in
 
1413
    let m_size = max 0 (p_size - 16) in
 
1414
    out 
 
1415
      ~max_input_size:m_size ~minor_status:0l ~major_status:(`None,`None,[])
 
1416
      ()
 
1417
    
 
1418
end