vendor multipart form fork (#208)

* vendor multipart form fork * wip * wip * fix nix buidl
anmonteiro · Aug 27, 2024 · df0843b · df0843b
1 parent cb0e8fa
commit df0843b
Show file tree

Hide file tree

Showing 16 changed files with 239 additions and 205 deletions.
diff --git a/.github/workflows/opam-build.yml b/.github/workflows/opam-build.yml
@@ -29,6 +29,8 @@ jobs:
     steps:
       - name: Checkout code
         uses: actions/checkout@v4
+        with:
+          submodules: recursive
 
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
         uses: ocaml/setup-ocaml@v2

diff --git a/.gitmodules b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "vendor/multipart_form"]
+	path = vendor/multipart_form
+	url = [email protected]:anmonteiro/multipart_form.git
diff --git a/dune b/dune
@@ -29,3 +29,5 @@
     --write-to
     %{target})
    (bash "echo \"$(cat %{target} | jq -r)\" > %{target}"))))
+
+(vendored_dirs vendor)
diff --git a/dune-project b/dune-project
@@ -37,7 +37,9 @@
   gluten-eio
   h2-eio
   httpun-ws
-  (multipart_form :dev)
+  pecu
+  prettym
+  unstrctrd
   (eio_main
    (>= "1.0"))
   (dune-site :with-test)

diff --git a/lib/form.ml b/lib/form.ml
@@ -32,6 +32,8 @@
 open Import
 
 module Multipart = struct
+  module Multipart_form = Piaf_multipart_form.Multipart_form
+
   type t =
     { name : string
     ; filename : string option
@@ -44,8 +46,7 @@ module Multipart = struct
     Buffer.add_string ctbuf ct;
     Buffer.add_char ctbuf '\r';
     Buffer.add_char ctbuf '\n';
-    let ct = Multipart_form.Content_type.of_string (Buffer.contents ctbuf) in
-    match ct with
+    match Multipart_form.Content_type.of_string (Buffer.contents ctbuf) with
     | Ok { Multipart_form.Content_type.ty = `Multipart; _ } -> true
     | Ok _ | Error _ -> false
 

diff --git a/multipart/dune b/multipart/dune
@@ -1,4 +1,4 @@
 (library
  (name multipart)
  (public_name piaf.multipart)
- (libraries faraday ke multipart_form eio piaf.stream))
+ (libraries faraday ke piaf.multipart_form eio piaf.stream))
diff --git a/multipart/multipart.ml b/multipart/multipart.ml
@@ -29,138 +29,8 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
 
-module List = struct
-  include List
-
-  let concat_map f l =
-    let rec aux f acc = function
-      | [] -> rev acc
-      | x :: l ->
-        let xs = f x in
-        aux f (rev_append xs acc) l
-    in
-    aux f [] l
-end
-
-module Pp = struct
-  let pp_extension formatter t =
-    let payload = match t with `Ietf_token x | `X_token x -> x in
-    Format.fprintf formatter "%s" payload
-
-  let pp_ty = Multipart_form.Content_type.Type.pp
-
-  let pp_subty formatter t =
-    let payload =
-      match t with `Ietf_token x | `Iana_token x | `X_token x -> x
-    in
-    Format.fprintf formatter "%s" payload
-
-  let pp_content_type formatter { Multipart_form.Content_type.ty; subty; _ } =
-    Format.fprintf formatter "%a/%a" pp_ty ty pp_subty subty
-
-  let pp_value formatter t =
-    let ty, payload =
-      match t with
-      | Multipart_form.Content_type.Parameters.String x -> "String", x
-      | Token x -> "Token", x
-    in
-    Format.fprintf formatter "%s: %s" ty payload
-
-  let pp_disposition_type formatter t =
-    let ty =
-      match t with
-      | `Inline -> "inline"
-      | `Attachment -> "attachment"
-      | (`Ietf_token _ | `X_token _) as ext ->
-        Format.asprintf "%a" pp_extension ext
-    in
-    Format.fprintf formatter "%s" ty
-
-  let pp_unstructured formatter t =
-    let pp_one formatter (t : Unstrctrd.elt) =
-      let s =
-        match t with
-        | `Uchar u -> Format.asprintf "Uchar: %c" (Uchar.to_char u)
-        | `CR -> "CR"
-        | `LF -> "LF"
-        | `WSP s -> Format.asprintf "WSP: %s" (s :> string)
-        | `FWS wsp -> Format.asprintf "FWS: %s" (wsp :> string)
-        | `d0 -> "d0"
-        | `OBS_NO_WS_CTL obs -> Format.asprintf "OB_NO_WS_CTL: %c" (obs :> char)
-        | `Invalid_char invalid_char ->
-          Format.asprintf "Invalid_char: %c" (invalid_char :> char)
-      in
-      Format.fprintf formatter "%s" s
-    in
-    Format.pp_print_list
-      ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ")
-      pp_one
-      formatter
-      t
-
-  let pp_field formatter t =
-    let open Multipart_form.Field in
-    match t with
-    | Field (_, Content_type, { ty; subty; parameters }) ->
-      Format.fprintf
-        formatter
-        "Content-Type { ty: %a; subty: %a; params: [ %a ] }"
-        pp_ty
-        ty
-        pp_subty
-        subty
-        (Format.pp_print_list
-           ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ")
-           (fun fmt (name, value) ->
-              Format.fprintf fmt "%s, %a" name pp_value value))
-        parameters
-    | Field (_, Content_encoding, enc) ->
-      Format.fprintf
-        formatter
-        "Encoding: %a"
-        Multipart_form.Content_encoding.pp
-        enc
-    | Field (_, Content_disposition, dispo) ->
-      Format.fprintf
-        formatter
-        "Content-Disposition: %a"
-        Multipart_form.Content_disposition.pp
-        dispo
-    | Field (field_name, Field, unstructured) ->
-      Format.fprintf
-        formatter
-        "Field (%a, %a)"
-        Multipart_form.Field_name.pp
-        field_name
-        pp_unstructured
-        (unstructured :> Unstrctrd.elt list)
-
-  (* let rec pp_contents formatter t = *)
-  (* let pp_atom formatter { Multipart_form.header; body } = *)
-  (* Format.fprintf *)
-  (* formatter *)
-  (* "{ fields: [ %a ]; contents: %a }" *)
-  (* (Format.pp_print_list *)
-  (* ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") *)
-  (* pp_field) *)
-  (* header *)
-  (* (pp_option ~pp:pp_contents) *)
-  (* body *)
-  (* in *)
-  (* match t with *)
-  (* | Multipart_form.Leaf x -> *)
-  (* Format.fprintf formatter "{ Contents: %a }" pp_atom x *)
-  (* | Multipart lst -> *)
-  (* Format.fprintf *)
-  (* formatter *)
-  (* "{ Multipart: [ %a ] }" *)
-  (* (Format.pp_print_list *)
-  (* ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") *)
-  (* pp_atom) *)
-  (* lst *)
-end
-
-(* type t = string option Multipart_form.t *)
+module Multipart_form = Piaf_multipart_form.Multipart_form
+module Pp = Pp
 
 let content_type header =
   let open Multipart_form in
@@ -232,7 +102,6 @@ let rec result_headers t =
   in
   match t with
   | Multipart { header; body } ->
-    Format.eprintf "nameof: %B@." (Option.is_some (name_of_header header));
     let headers = atom_to_headers [] header in
     (match body with
     | [] -> headers
@@ -323,7 +192,7 @@ let extract_parts ~emit ~finish ~max_chunk_size ~content_type stream =
         then Error "POST buffer has grown too much"
         else if not (Qe.is_empty ke)
         then
-          (* XXX(anmonteiro): It's OK to only read the first slice of the
+          (* NOTE(anmonteiro): It's OK to only read the first slice of the
            * queue. Ke's implementation returns at most 2 buffers from `peek`:
            * the second one is returned if the buffer has wrapped around its
            * capacity. *)

diff --git a/multipart/multipart.mli b/multipart/multipart.mli
@@ -29,6 +29,8 @@
  * POSSIBILITY OF SUCH DAMAGE.
  *---------------------------------------------------------------------------*)
 
+module Multipart_form = Piaf_multipart_form.Multipart_form
+
 type t
 
 module Pp : sig

diff --git a/multipart/pp.ml b/multipart/pp.ml
@@ -0,0 +1,117 @@
+module Multipart_form = Piaf_multipart_form.Multipart_form
+
+let pp_extension formatter t =
+  let payload = match t with `Ietf_token x | `X_token x -> x in
+  Format.fprintf formatter "%s" payload
+
+let pp_ty = Multipart_form.Content_type.Type.pp
+
+let pp_subty formatter t =
+  let payload =
+    match t with `Ietf_token x | `Iana_token x | `X_token x -> x
+  in
+  Format.fprintf formatter "%s" payload
+
+let pp_content_type formatter { Multipart_form.Content_type.ty; subty; _ } =
+  Format.fprintf formatter "%a/%a" pp_ty ty pp_subty subty
+
+let pp_value formatter t =
+  let ty, payload =
+    match t with
+    | Multipart_form.Content_type.Parameters.String x -> "String", x
+    | Token x -> "Token", x
+  in
+  Format.fprintf formatter "%s: %s" ty payload
+
+let pp_disposition_type formatter t =
+  let ty =
+    match t with
+    | `Inline -> "inline"
+    | `Attachment -> "attachment"
+    | (`Ietf_token _ | `X_token _) as ext ->
+      Format.asprintf "%a" pp_extension ext
+  in
+  Format.fprintf formatter "%s" ty
+
+let pp_unstructured formatter t =
+  let pp_one formatter (t : Unstrctrd.elt) =
+    let s =
+      match t with
+      | `Uchar u -> Format.asprintf "Uchar: %c" (Uchar.to_char u)
+      | `CR -> "CR"
+      | `LF -> "LF"
+      | `WSP s -> Format.asprintf "WSP: %s" (s :> string)
+      | `FWS wsp -> Format.asprintf "FWS: %s" (wsp :> string)
+      | `d0 -> "d0"
+      | `OBS_NO_WS_CTL obs -> Format.asprintf "OB_NO_WS_CTL: %c" (obs :> char)
+      | `Invalid_char invalid_char ->
+        Format.asprintf "Invalid_char: %c" (invalid_char :> char)
+    in
+    Format.fprintf formatter "%s" s
+  in
+  Format.pp_print_list
+    ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ")
+    pp_one
+    formatter
+    t
+
+let pp_field formatter t =
+  let open Multipart_form.Field in
+  match t with
+  | Field (_, Content_type, { ty; subty; parameters }) ->
+    Format.fprintf
+      formatter
+      "Content-Type { ty: %a; subty: %a; params: [ %a ] }"
+      pp_ty
+      ty
+      pp_subty
+      subty
+      (Format.pp_print_list
+         ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ")
+         (fun fmt (name, value) ->
+            Format.fprintf fmt "%s, %a" name pp_value value))
+      parameters
+  | Field (_, Content_encoding, enc) ->
+    Format.fprintf
+      formatter
+      "Encoding: %a"
+      Multipart_form.Content_encoding.pp
+      enc
+  | Field (_, Content_disposition, dispo) ->
+    Format.fprintf
+      formatter
+      "Content-Disposition: %a"
+      Multipart_form.Content_disposition.pp
+      dispo
+  | Field (field_name, Field, unstructured) ->
+    Format.fprintf
+      formatter
+      "Field (%a, %a)"
+      Multipart_form.Field_name.pp
+      field_name
+      pp_unstructured
+      (unstructured :> Unstrctrd.elt list)
+
+(* let rec pp_contents formatter t = *)
+(* let pp_atom formatter { Multipart_form.header; body } = *)
+(* Format.fprintf *)
+(* formatter *)
+(* "{ fields: [ %a ]; contents: %a }" *)
+(* (Format.pp_print_list *)
+(* ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") *)
+(* pp_field) *)
+(* header *)
+(* (pp_option ~pp:pp_contents) *)
+(* body *)
+(* in *)
+(* match t with *)
+(* | Multipart_form.Leaf x -> *)
+(* Format.fprintf formatter "{ Contents: %a }" pp_atom x *)
+(* | Multipart lst -> *)
+(* Format.fprintf *)
+(* formatter *)
+(* "{ Multipart: [ %a ] }" *)
+(* (Format.pp_print_list *)
+(* ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") *)
+(* pp_atom) *)
+(* lst *)