Source file email.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
module Stable_no_v1_bin_io = struct
  open! Core.Core_stable

  module V1 = struct
    type t =
      { headers : Headers.Stable.V1.t
      ; raw_content : Email_raw_content.Stable.V1.t
      }
    [@@deriving sexp]
  end
end

open Core
open Or_error.Let_syntax

module T = struct
  type t = Stable_no_v1_bin_io.V1.t =
    { headers : Headers.t
    ; raw_content : Email_raw_content.t
    }
  [@@deriving sexp_of, fields, compare, hash]
end

include T
include Comparable.Make_plain (T)
include Hashable.Make_plain (T)

(* The default type of a message depends on the type of its parent,
   so we need to pass it around. *)
let of_bigstring_shared bstr =
  let lexbuf = Bigstring_shared.to_lexbuf bstr in
  let%map (`Message (headers, content_offset)) =
    try
      Ok
        (Email_grammar.message (Email_lexer.message (Email_lexer_state.create ())) lexbuf)
    with
    | _ ->
      (* Looks like lexer just throws Failure, not Parsing.Parse_error *)
      let pos = lexbuf.Lexing.lex_curr_p in
      Or_error.error_string
        (sprintf
           "Error parsing email at line %d, column %d"
           pos.Lexing.pos_lnum
           (pos.Lexing.pos_cnum - pos.Lexing.pos_bol))
  in
  let headers = Headers.of_list ~normalize:`None headers in
  let raw_content =
    match content_offset with
    | `Truncated -> None
    | `Bad_headers pos -> Some (Bigstring_shared.sub ~pos bstr)
    | `Content_offset pos -> Some (Bigstring_shared.sub ~pos bstr)
  in
  { headers
  ; raw_content = Email_raw_content.Expert.of_bigstring_shared_option raw_content
  }
;;

let of_string str =
  of_bigstring_shared (Bigstring_shared.of_string str) |> Or_error.ok_exn
;;

let of_bigstring bstr =
  of_bigstring_shared (Bigstring_shared.of_bigstring bstr) |> Or_error.ok_exn
;;

let of_bigbuffer buffer = of_bigstring (Bigbuffer.big_contents buffer)

(* Message bodies are optional. I highly doubt anybody would handle [None] differently
   from [Some ""], so we don't expose this detail. It allows us to be smarter with
   [to_string] so we don't add a newline. *)
let to_string_monoid ?(eol_except_raw_content = `LF) t =
  let optional_body =
    match Email_raw_content.Expert.to_bigstring_shared_option t.raw_content with
    | None -> []
    | Some raw_content ->
      [ String_monoid.concat
          [ String_monoid.of_string (Lf_or_crlf.to_string eol_except_raw_content)
          ; String_monoid.of_bigstring (Bigstring_shared.to_bigstring raw_content)
          ]
      ]
  in
  String_monoid.concat
    (Headers.to_string_monoid ~eol:eol_except_raw_content t.headers :: optional_body)
;;

let to_string ?eol_except_raw_content t =
  String_monoid.to_string (to_string_monoid ?eol_except_raw_content t)
;;

let to_bigstring ?eol_except_raw_content t =
  String_monoid.to_bigstring (to_string_monoid ?eol_except_raw_content t)
;;

let to_bigstring_shared ?eol_except_raw_content t =
  Bigstring_shared.of_string_monoid (to_string_monoid ?eol_except_raw_content t)
;;

let create = Fields.create
let set_headers t headers = { t with headers }
let set_raw_content t raw_content = { t with raw_content }
let modify_headers t ~f = set_headers t (f t.headers)
let modify_raw_content t ~f = set_raw_content t (f (raw_content t))

let save ?temp_file ?perm ?fsync ?eol_except_raw_content t path =
  let open Async in
  Writer.with_file_atomic ?temp_file ?perm ?fsync path ~f:(fun writer ->
    String_monoid.iter (to_string_monoid ?eol_except_raw_content t) ~f:(function
      | String_monoid.Underlying.Char c -> Writer.write_char writer c
      | String str -> Writer.write writer str
      | Bigstring bstr -> Writer.schedule_bigstring writer bstr);
    return ())
;;

module Stable = struct
  module V1 = struct
    include Stable_no_v1_bin_io.V1

    include
      Binable.Of_binable_without_uuid [@alert "-legacy"]
        (Bigstring.Stable.V1)
        (struct
          type nonrec t = t

          let to_binable t = to_bigstring t
          let of_binable = of_bigstring
        end)
  end
end