Source file rfc2046.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
open Angstrom

(* From RFC 2046

     bcharsnospace := DIGIT / ALPHA / "'" / "(" / ")" /
                      "+" / "_" / "," / "-" / "." /
                      "/" / ":" / "=" / "?"
*)
let is_bcharsnospace = function
  | '\'' | '(' | ')' | '+' | '_' | ','
  | '-' | '.' | '/' | ':' | '=' | '?' -> true
  | 'a' .. 'z' | 'A' .. 'Z' -> true
  | '0' .. '9' -> true
  | _ -> false

(* From RFC 2046

     bchars := bcharsnospace / " "
*)
let is_bchars = function
  | ' ' -> true
  | c -> is_bcharsnospace c

(* From RFC 2046

     dash-boundary := "--" boundary
                      ; boundary taken from the value of
                      ; boundary parameter of the
                      ; Content-Type field.
*)
let make_dash_boundary boundary =
  "--" ^ boundary

let dash_boundary boundary =
  string (make_dash_boundary boundary)

let make_delimiter boundary =
  "\r\n" ^ (make_dash_boundary boundary)

let make_close_delimiter boundary =
  (make_delimiter boundary) ^ "--"

let close_delimiter boundary =
  string (make_close_delimiter boundary)

(* NOTE: this parser terminate at the boundary, however it does not consume it. *)
let discard_all_to_dash_boundary boundary =
  let check_boundary =
    let dash_boundary = make_dash_boundary boundary in
    let expected_len = String.length dash_boundary in
    Unsafe.peek expected_len
      (fun ba ~off ~len ->
         let raw = Bigstringaf.substring ba ~off ~len in
         String.equal raw dash_boundary) in
  fix @@ fun m ->
  skip_while ((<>) '-') *> peek_char >>= function
  | Some '-' ->
    (check_boundary >>= function
      | true -> return ()
      | false -> advance 1 *> m)
  | Some _ -> advance 1 *> m (* impossible case? *)
  | None -> return ()

(* From RFC 2046

     transport-padding := *LWSP-char
                          ; Composers MUST NOT generate
                          ; non-zero length transport
                          ; padding, but receivers MUST
                          ; be able to handle padding
                          ; added by message transports.
*)
let transport_padding = skip_while (function '\x09' | '\x20' -> true | _ -> false)

let discard_all_to_delimiter boundary =
  let check_delimiter =
    let delimiter = make_delimiter boundary in
    let expected_len = String.length delimiter in
    Unsafe.peek expected_len
      (fun ba ~off ~len ->
         let raw = Bigstringaf.substring ba ~off ~len in
         String.equal raw delimiter) in
  fix @@ fun m ->
  skip_while ((<>) '\r') *> peek_char >>= function
  | Some '\r' ->
    (check_delimiter >>= function
      | true -> return ()
      | false -> advance 1 *> m)
  | Some _ -> advance 1 *> m (* impossible case? *)
  | None -> return ()

let nothing_to_do = Fmt.kstrf fail "nothing to do"

let crlf = string "\r\n"

let body_part body =
  Header.Decoder.header >>= fun header ->
  ((crlf *> return `CRLF) <|> (return `Nothing))
  >>= (function
      | `CRLF -> body header >>| Option.some
      | `Nothing -> return None)
  >>| fun body -> (header, body)

let encapsulation boundary body =
  string (make_delimiter boundary)
  *> transport_padding
  *> crlf
  *> body_part body

(* From RFC 2046:

     preamble := discard-text
     discard-text := *( *text CRLF)
                     ; May be ignored or discarded.

   XXX(dinosaure): this parser consume the last CRLF which is NOT included in the ABNF. *)
let preambule boundary = discard_all_to_dash_boundary boundary

let epilogue parent = match parent with
  | Some boundary -> discard_all_to_delimiter boundary
  | None -> skip_while (fun _ -> true)

let multipart_body ?parent boundary body =
  option () (preambule boundary) (* see [preambule]. *)
  *> dash_boundary boundary
  *> transport_padding
  *> crlf
  *> body_part body
  >>= fun x -> many (encapsulation boundary body)
  >>= fun r -> ((close_delimiter boundary
                 *> transport_padding
                 *> option () (epilogue parent))
                <|> return ())
               *> return (x :: r)