package piaf

You can search for identifiers within the package.

in-package search v0.2.0

An HTTP library with HTTP/2 support written entirely in OCaml

Install

Dune Dependency

github.com Readme Changelog Edit opam file Versions (2)

Authors

A

Antonio Nuno Monteiro <anmonteiro@gmail.com>

Maintainers

A

Antonio Nuno Monteiro <anmonteiro@gmail.com>

Sources

piaf-0.2.0.tbz

sha256=07fa9009a52faeaae6d86116e75007f5279b185c7bc7c95aab9455f2107370fb

sha512=dfde4bd0a5c8a3b795a8e3d6f6e1f9f1864a9eb0a1b96763c17515d771566af7623ca64db671a8dce2c7838dad08d8465db98f5e4f8dcf5e1a386ef5b29da56c

doc/src/piaf.multipart_form/rfc2046.ml.html

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
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.kstr fail "nothing to do"
let crlf = char '\r' *> char '\n'

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

let encapsulation boundary body =
  string (make_delimiter boundary)
  *> transport_padding
  *> crlf
  *> commit
  *> 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
  *> commit
  *> body_part body
  >>= fun x ->
  many (encapsulation boundary body) >>= fun r ->
  (commit
   *> close_delimiter boundary
   *> transport_padding
   *> option () (epilogue parent)
  <|> return ())
  *> return (x :: r)