Source file `proxy.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
module Forward = struct
  type pattern = Name of string | Ipaddr_prefix of Ipaddr.Prefix.t
  type no_proxy_patterns = Wildcard | Patterns of pattern list

  (* Used to ignore trailing dots in hostnames, as per
     https://github.com/curl/curl/blob/49ef2f8d1ef78e702c73f5d72242301cc2a0157e/lib/noproxy.c#L170-L172

     When [first_leading = true], it also trims the first leading dot, as per
     https://github.com/curl/curl/blob/49ef2f8d1ef78e702c73f5d72242301cc2a0157e/lib/noproxy.c#L198-L201 *)
  let trim_dots ~first_leading s =
    let len = String.length s in
    let i = ref 0 in
    if first_leading && !i < len && String.unsafe_get s !i = '.' then incr i;
    let j = ref (len - 1) in
    while !j >= !i && String.unsafe_get s !j = '.' do
      decr j
    done;
    if !j >= !i then String.sub s !i (!j - !i + 1) else ""

  let strncasecompare a b n =
    let a = String.(sub a 0 (min (length a) n) |> lowercase_ascii)
    and b = String.(sub b 0 (min (length b) n) |> lowercase_ascii) in
    String.equal a b

  let no_proxy_from_env_value no_proxy =
    match no_proxy with
    | None -> Patterns []
    | Some no_proxy ->
        if no_proxy = "*" then Wildcard
        else
          let patterns =
            no_proxy
            |> String.split_on_char ','
            |> List.filter_map (fun pattern ->
                   if pattern = "" then None else Some (String.trim pattern))
            |> List.map (fun pattern ->
                   match Ipaddr.of_string pattern with
                   | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr)
                   | Error _ -> (
                       match Ipaddr.Prefix.of_string pattern with
                       | Ok prefix -> Ipaddr_prefix prefix
                       | Error _ -> Name (trim_dots ~first_leading:true pattern)
                       ))
          in
          Patterns patterns

  let check_no_proxy uri pattern =
    let host = Uri.host_with_default ~default:"" uri in
    if String.length host = 0 then true
    else
      match pattern with
      | Wildcard -> true
      | Patterns patterns -> (
          match Ipaddr.of_string host with
          | Ok hostip ->
              List.exists
                (function
                  | Name _ -> false
                  | Ipaddr_prefix network -> Ipaddr.Prefix.mem hostip network)
                patterns
          | Error _ ->
              let name = trim_dots ~first_leading:false host in
              List.exists
                (function
                  | Ipaddr_prefix _ -> false
                  | Name pattern ->
                      let patternlen = String.length pattern
                      and namelen = String.length name in
                      if patternlen = namelen then
                        (* An exact (case-insensitive) match *)
                        strncasecompare pattern name namelen
                      else if patternlen < namelen then
                        (* pattern is a (case-insensitive) suffix of the host,
                     starting after any subdomain prefix.

                     E.g., [example.com] is a suffix of [www.example.com] and
                     [home.example.com], but not of [nonexample.com]. *)
                        let match_start = namelen - patternlen in
                        let host_suffix =
                          String.sub name match_start patternlen
                        in
                        name.[match_start - 1] = '.'
                        && strncasecompare pattern host_suffix patternlen
                      else false)
                patterns)

  type ('direct, 'tunnel) t = Direct of 'direct | Tunnel of 'tunnel

  type ('direct, 'tunnel) servers = {
    by_scheme : (string * ('direct, 'tunnel) t) list;
    no_proxy_patterns : no_proxy_patterns;
    default_tunnel : ('direct, 'tunnel) t option;
    default_direct : ('direct, 'tunnel) t option;
  }

  (* Uri schemes that should be used with tunnelled proxies  *)
  let is_tunnel_scheme = function "https" -> true | _ -> false

  let make_servers ~no_proxy_patterns ~(default_proxy : Uri.t option)
      ~(scheme_proxies : (string * Uri.t) list) ~(direct : Uri.t -> 'direct)
      ~(tunnel : Uri.t -> 'tunnel) : ('direct, 'tunnel) servers =
    let by_scheme =
      List.map
        (fun (scheme, uri) ->
          let proxy =
            if is_tunnel_scheme scheme then Tunnel (tunnel uri)
            else Direct (direct uri)
          in
          (scheme, proxy))
        scheme_proxies
    in
    let no_proxy_patterns = no_proxy_from_env_value no_proxy_patterns in
    let default_tunnel, default_direct =
      match default_proxy with
      | None -> (None, None)
      | Some uri -> (Some (Tunnel (tunnel uri)), Some (Direct (direct uri)))
    in
    { by_scheme; no_proxy_patterns; default_tunnel; default_direct }

  let get (servers : ('direct, 'tunnel) servers) (uri : Uri.t) :
      ('direct, 'tunnel) t option =
    if check_no_proxy uri servers.no_proxy_patterns then None
    else
      let scheme = Option.value ~default:"" (Uri.scheme uri) in
      match List.assoc scheme servers.by_scheme with
      | proxy -> Some proxy
      | exception Not_found ->
          if is_tunnel_scheme scheme then servers.default_tunnel
          else servers.default_direct
end