1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
open! Core
open! Async
open! Import
type 'principal authorize =
Socket.Address.Inet.t -> 'principal -> [ `Accept | `Reject ] Deferred.t
let bool_to_auth = function
| true -> `Accept
| false -> `Reject
;;
module Krb = struct
type t =
| Single_realm_accept_all
| Single_realm of Principal.Name.t authorize
| Cross_realm of Cross_realm_principal_name.t authorize
[@@deriving variants]
let create_async f = Single_realm f
let create f = create_async (fun addr principal -> f addr principal |> Deferred.return)
let accept_all = Single_realm_accept_all
let accept_single allowed =
create (fun _ principal -> bool_to_auth (Principal.Name.equal allowed principal))
;;
let accept_multiple allowed =
create (fun _ principal -> bool_to_auth (Set.mem allowed principal))
;;
module Cross_realm = struct
let create f = Cross_realm (fun addr principal -> f addr principal |> Deferred.return)
let accept_single allowed =
create (fun _ principal ->
bool_to_auth (Cross_realm_principal_name.equal allowed principal))
;;
let accept_multiple allowed =
create (fun _ principal -> bool_to_auth (Set.mem allowed principal))
;;
end
end
module Anon = struct
type t = Principal.Name.t option authorize
let of_krb ?(on_anon = `Accept) f addr maybe_principal =
match maybe_principal with
| None -> return on_anon
| Some principal -> f addr principal |> return
;;
let create f addr principal_opt = f addr principal_opt |> Deferred.return
let accept_all = of_krb (fun _ _ -> `Accept)
let accept_single allowed =
of_krb (fun _ principal -> bool_to_auth (Principal.Name.equal allowed principal))
;;
let accept_multiple allowed =
of_krb (fun _ principal -> bool_to_auth (Set.mem allowed principal))
;;
end
include Krb
let krb_of_anon auth_anon =
create_async (fun addr principal -> auth_anon addr (Some principal))
;;
let authorization_method = function
| Single_realm_accept_all -> `Accept_all
| Single_realm _ | Cross_realm _ -> `Custom
;;
module For_internal_use = struct
let authorize auth addr principal =
match auth with
| Single_realm_accept_all -> return `Accept
| Single_realm single_auth ->
single_auth addr (Principal.Name.of_cross_realm principal)
| Cross_realm cr_auth -> cr_auth addr principal
;;
let allows_cross_realm = function
| Single_realm_accept_all | Single_realm _ -> false
| Cross_realm _ -> true
;;
module Anon = struct
let authorize auth addr maybe_principal = auth addr maybe_principal
end
end