package mrmime

  1. Overview
  2. Docs
package mrmime
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

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
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 = Bstr.sub_string 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 = Bstr.sub_string 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 = Format.kasprintf fail "nothing to do"
let crlf = string "\r\n"

let possible_boundary boundary =
  peek_string (String.length (make_delimiter boundary)) >>= fun str ->
  if String.equal (make_delimiter boundary) str then return `Nothing
  else fail "boundary"

let boundary_or_crlf boundary =
  possible_boundary boundary <|> crlf *> return `CRLF

let body_part g boundary body =
  Header.Decoder.header g >>= fun header ->
  ( boundary_or_crlf boundary >>= function
    | `CRLF -> body header >>| Option.some
    | `Nothing -> return None )
  >>| fun body -> (header, body)

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