Source file credentials.ml

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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
module type Mech = Auth.Client

module Stable = struct
  open Core.Core_stable

  module Login = struct
    module V1 = struct
      type t =
        { on_behalf_of : string option [@sexp.option]
        ; username : string
        ; password : string
        }
      [@@deriving sexp]
    end
  end

  module V1 = struct
    type t =
      { username : string
      ; password : string
      }
    [@@deriving sexp]
  end

  module V2 = struct
    type elt =
      | Login of Login.V1.t
      | Anon
    [@@deriving sexp]

    type t = elt list [@@deriving sexp]

    let of_v1 { V1.username; password } =
      let login = { Login.V1.on_behalf_of = None; username; password } in
      [ Login login ]
    ;;
  end

  module V3 = struct
    type mech = (module Mech)

    (*_ stub [sexp] implementation for [mech] *)
    let sexp_of_mech (module A : Mech) = [%sexp (A.mechanism : string)]
    let mech_of_sexp = [%of_sexp: _]

    type elt =
      | Anon
      | Login of Login.V1.t
      | Custom of mech
    [@@deriving sexp]

    type t = elt list [@@deriving sexp]

    let of_v2 =
      Core.List.map ~f:(function
        | V2.Login login -> Login login
        | V2.Anon -> Anon)
    ;;
  end
end

open! Core
open Async_smtp_types

module Login = struct
  type t = Stable.Login.V1.t =
    { on_behalf_of : string option [@sexp.option]
    ; username : string
    ; password : (string[@sexp.opaque])
    }
  [@@deriving sexp_of]
end

type mech = (module Mech)

let sexp_of_mech = [%sexp_of: Stable.V3.mech]

type elt = Stable.V3.elt =
  | Anon
  | Login of Login.t
  | Custom of mech
[@@deriving sexp_of]

let sexp_of_elt = function
  | Custom mech -> sexp_of_mech mech
  | elt -> sexp_of_elt elt
;;

type t = elt list [@@deriving sexp_of]

let allows_anon =
  List.exists ~f:(function
    | Login _ | Custom _ -> false
    | Anon -> true)
;;

let anon = [ Anon ]

let login ?on_behalf_of ~username ~password () =
  [ Login { Login.on_behalf_of; username; password } ]
;;

let custom mech = [ Custom mech ]

let get_methods t ~tls =
  List.concat_map t ~f:(function
    | Anon -> []
    | Login { Login.on_behalf_of; username; password } ->
      if not tls
      then []
      else
        let module Cred = struct
          let on_behalf_of = on_behalf_of
          let username = username
          let password = password
        end
        in
        (module Auth.Plain.Client (Cred) : Mech)
        ::
        (if Option.is_none on_behalf_of
         then [ (module Auth.Login.Client (Cred) : Mech) ]
         else [])
    | Custom ((module A : Mech) as mech) ->
      if tls || not A.require_tls then [ mech ] else [])
;;

let get_auth_client t ~tls extensions =
  let client_mechs = get_methods t ~tls in
  let server_mechs =
    List.concat_map extensions ~f:(function
      | Smtp_extension.Auth mechs -> mechs
      | _ -> [])
  in
  List.find_map server_mechs ~f:(fun m ->
    List.find client_mechs ~f:(fun (module M : Mech) ->
      String.Caseless.equal m M.mechanism))
  |> function
  | Some mech -> Ok (`Auth_with mech)
  | None ->
    if allows_anon t
    then Ok `Anon
    else (
      let client_mechs =
        List.map client_mechs ~f:(fun (module M : Mech) -> M.mechanism)
      in
      Or_error.error_s
        [%sexp
          "No common auth mechanism available and ANON authentication not allowed by \
           client"
        , { client_mechs : string list; server_mechs : string list }])
;;