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
type t =
{ local : [ `String of string | `Dot_string of string list ]
; domain : Domain.t
; rest : Domain.t list }
let equal_local a b = match a, b with
| (`String a | `Dot_string [ a ]),
(`String b | `Dot_string [ b ]) ->
String.(equal (lowercase_ascii a) (lowercase_ascii b))
| `Dot_string a, `Dot_string b ->
(try List.for_all2 (fun a b -> String.(equal (lowercase_ascii a) (lowercase_ascii b))) a b
with _ -> false)
| _, _ -> false
let equal a b =
equal_local a.local b.local
&& Domain.equal a.domain b.domain
&& (try List.for_all2 Domain.equal a.rest b.rest with _ -> false)
let pp_local ppf = function
| `String x -> Fmt.(quote string) ppf x
| `Dot_string l -> Fmt.(list ~sep:(const string ".") string) ppf l
let pp ppf { local; domain; rest; } =
match rest with
| [] -> Fmt.pf ppf "<%a@%a>" pp_local local Domain.pp domain
| rest ->
Fmt.pf ppf "<%a:%a@%a>"
Fmt.(list ~sep:(const string ",") (prefix (const string "@") Domain.pp)) rest
pp_local local Domain.pp domain
module Parser = struct
open Angstrom
let at_domain = char '@' *> Domain.Parser.domain
let a_d_l = at_domain >>= fun x -> many (char ',' *> at_domain) >>| fun r -> x :: r
let is_atext = function
| 'a' .. 'z'
|'A' .. 'Z'
|'0' .. '9'
|'!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '/' | '=' | '?'
|'^' | '_' | '`' | '{' | '}' | '|' | '~' ->
true
| _ -> false
let is_qtextSMTP = function
| '\032' | '\033' | '\035' .. '\091' | '\093' .. '\126' -> true
| _ -> false
let atom = take_while1 is_atext
let dot_string = atom >>= fun x -> many (char '.' *> atom) >>| fun r -> `Dot_string (x :: r)
let quoted_pairSMTP =
char '\\' *> satisfy (function '\032' .. '\126' -> true | _ -> false) >>| String.make 1
let qcontentSMTP = quoted_pairSMTP <|> take_while1 is_qtextSMTP
let quoted_string =
char '"' *> many qcontentSMTP <* char '"' >>| String.concat "" >>| fun x -> `String x
let local_part = dot_string <|> quoted_string
let mailbox =
local_part
>>= fun local -> char '@' *> (Domain.Parser.domain <|> Domain.Parser.address_literal)
>>| fun domain -> (local, domain)
let path =
char '<' *> option [] (a_d_l <* char ':')
>>= fun rest -> mailbox <* char '>'
>>= fun (local, domain) -> return { local; domain; rest; }
end
module Encoder = struct
let need_to_escape, escape_char =
let bindings = [('\000', '\000')
;('\\', '\\')
;('\x07', 'a')
;('\b', 'b')
;('\t', 't')
;('\n', 'n')
;('\x0b', 'v')
;('\x0c', 'f')
;('\r', 'r')
;('"', '"')] in
( (fun chr -> List.mem_assoc chr bindings)
, fun chr -> List.assoc chr bindings )
let escape x =
let len = String.length x in
let res = Buffer.create (len * 2) in
let pos = ref 0 in
while !pos < len do
if need_to_escape x.[!pos] then (
Buffer.add_char res '\\' ;
Buffer.add_char res (escape_char x.[!pos]) )
else Buffer.add_char res x.[!pos] ;
incr pos
done ;
Buffer.contents res
let local_to_string = function
| `String x ->
Fmt.strf "%a" Fmt.(using escape string) x
| `Dot_string l ->
Fmt.strf "%a" Fmt.(list ~sep:(const string ".") string) l
let to_string x = match x.rest with
| [] ->
Fmt.strf "<%s@%s>" (local_to_string x.local) (Domain.to_string x.domain)
| rest ->
Fmt.strf "<%a:%s@%s>"
Fmt.(list ~sep:(const string ",")
(prefix
(const string "@")
(using Domain.to_string string))) rest
(local_to_string x.local)
(Domain.to_string x.domain)
end