Add encoding primitives and a compression middleware

dream.opam

@@ -54,6 +54,7 @@ depends: [
   "caqti-lwt"
   "conf-libev" {os != "win32"}
   "cstruct" {>= "6.0.0"}
+  "decompress" {>= "1.4.1"}
   "dream-httpaf" {>= "1.0.0~alpha2"}
   "dream-pure" {>= "1.0.0~alpha2"}
   "dune" {>= "2.7.0"}  # --instrument-with.

example/m-compress/README.md

@@ -0,0 +1,25 @@
+# `m-compress`
+
+<br>
+
+Demonstrate how to compress responses using the `Dream.compress` middleware.
+
+```ocaml
+let () =
+  Dream.run
+  @@ Dream.logger
+  @@ Dream.compress
+  @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Hello World!") ]
+```
+
+The middleware will parse the `Accept-Encoding` header from the requests and compress the responses accordingly.
+
+## Limitation
+
+As of now, the only supported encoding directives are `gzip` and `deflate`.
+
+Support for more compression methods will come when they are supported in `decompress`, the underlying compression library used in `dream-encoding`.
+
+<br>
+
+[Up to the tutorial index](../#readme)

example/m-compress/compress.ml

@@ -0,0 +1,3 @@
+let () =
+  Dream.run @@ Dream.logger @@ Dream.compress
+  @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Hello World!") ]

example/m-compress/dune

@@ -0,0 +1,5 @@
+(executable
+ (name compress)
+ (libraries dream))
+
+(data_only_dirs _esy esy.lock lib node_modules)

example/m-compress/dune-project

@@ -0,0 +1 @@
+(lang dune 2.0)

example/m-compress/esy.json

@@ -0,0 +1,18 @@
+{
+  "dependencies": {
+    "@opam/conf-libssl": "3",
+    "@opam/dream": "1.0.0~alpha5",
+    "@opam/dune": "^3.0",
+    "ocaml": "^4.14.0"
+  },
+  "devDependencies": {
+    "@opam/ocaml-lsp-server": "*"
+  },
+  "resolutions": {
+    "@opam/conf-libev": "esy-packages/libev:package.json#0b5eb6685b688649045aceac55dc559f6f21b829",
+    "esy-openssl": "esy-packages/esy-openssl#619ae2d46ca981ec26ab3287487ad98b157a01d1"
+  },
+  "scripts": {
+    "start": "dune exec --root . ./compress.exe"
+  }
+}

src/dream.ml

@@ -10,6 +10,7 @@ module Cipher = Dream__cipher.Cipher
 module Cookie = Dream__server.Cookie
 module Csrf = Dream__server.Csrf
 module Echo = Dream__server.Echo
+module Encoding = Dream__unix.Encoding
 module Error_handler = Dream__http.Error_handler
 module Flash = Dream__server.Flash
 module Form = Dream__server.Form
@@ -185,6 +186,14 @@ let receive_fragment = Helpers.receive_fragment
 let close_websocket = Message.close_websocket
 
 
+(* Encoding *)
+
+let with_encoded_body = Encoding.with_encoded_body
+let accepted_encodings = Encoding.accepted_encodings
+let accepted_encodings_with_weights = Encoding.accepted_encodings_with_weights
+let content_encodings = Encoding.content_encodings
+let preferred_content_encoding = Encoding.preferred_content_encoding
+
 
 (* JSON *)
 
@@ -216,6 +225,8 @@ let csrf_tag = Tag.csrf_tag ~now
 
 let no_middleware = Message.no_middleware
 let pipeline = Message.pipeline
+let compress = Encoding.compress
+let decompress = Encoding.decompress
 
 
 

src/dream.mli

@@ -898,6 +898,56 @@ val close_websocket : ?code:int -> websocket -> unit promise
     {{:https://tools.ietf.org/html/rfc6455#section-7.4} RFC 6455 §7.4}. *)
 
 
+(** {1 Encoding} *)
+
+val with_encoded_body :
+  ?algorithm:[`Deflate | `Gzip] -> string -> response -> response
+(** [with_encoded_body ?algorithm body response] replaces the body of the
+    response with [body] compressed with [algorithm] and adds the corresponding
+    [Content-Encoding] header.
+
+    [algorithm] defaults to [`Deflate]. *)
+
+val accepted_encodings :
+  'a message ->
+  [`Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string] list
+  option
+(** Retrieve the list of accepted encoding directives from the [Accept-Encoding]
+    header, ordered by quality weight in decreasing order.
+
+    If the request does not have an [Accept-Encoding] header, this returns
+    [None]. *)
+
+val accepted_encodings_with_weights :
+  'a message ->
+  ([`Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string] * int)
+  list
+  option
+(** Same as [accepted_encoding], but returns the quality weights associated to
+    the encoding directive. *)
+
+val content_encodings :
+  'a message ->
+  [`Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string] list
+  option
+(** Retrieve the list of content encoding directives from the [Content-Encoding]
+    header.
+
+    If the request does not have an [Content-Encoding] header, this returns
+    [None]. *)
+
+val preferred_content_encoding : 'a message -> [`Deflate | `Gzip] option
+(** Retrieve preferred encoding directive from the [Accept-Encoding].
+
+    The preferred encoding directive is the first supported algorithm in the
+    list of accepted directives sorted by quality weight.
+
+    If [*] is given as the preferred encoding, [`Gzip] is returned. This is to
+    be on par with the behavior of [compress].
+
+    If no algorithm is supported, or if the request does not have an
+    [Accept-Encoding] header, this returns [None]. *)
+
 
 (** {1 JSON}
 
@@ -1315,6 +1365,21 @@ Dream.pipeline [middleware_1; middleware_2] @@ handler
                middleware_1 @@ middleware_2 @@ handler
     v} *)
 
+val compress : middleware
+(** Middleware that reads the [Accept-Encoding] header of the request and
+    compresses the responses with the preferred supported algorithm. *)
+
+val decompress : middleware
+(** Middleware that reads the [Content-Encoding] of the request and decompresses
+    the body if all of the directives of the header are supported.
+
+    If one or more of the directive is not supported, an HTTP response
+    [415 Unsupported Media Type] is returned to the client.
+
+    Note that although HTTP supports encoding requests, it is rarely used in
+    practice. See [compress] to for a middleware that compresses the responses
+    instead. *)
+
 (* TODO Need a way to create fresh streams. *)
 (** {2 Stream transformers}
 

src/server/accept.ml

@@ -0,0 +1,169 @@
+(* From
+   https://github.com/lyrm/ocaml-httpadapter/blob/master/src-httpaf/accept.ml
+
+   Copyright (c) 2019 Carine Morel <[email protected]>
+
+   Permission to use, copy, modify, and distribute this software for any purpose
+   with or without fee is hereby granted, provided that the above copyright
+   notice and this permission notice appear in all copies.
+
+   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+   REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+   AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+   INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+   LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+   OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+   PERFORMANCE OF THIS SOFTWARE. *)
+
+open Angstrom
+open Printf
+
+type encoding =
+  | Encoding of string
+  | Gzip
+  | Compress
+  | Deflate
+  | Identity
+  | Any
+
+type p = string * string
+type q = int
+type 'a qlist = (q * 'a) list
+
+(** Lexer *)
+let is_space = function
+  | ' ' | '\t' -> true
+  | _ -> false
+
+let is_token = function
+  | '\000' .. '\031'
+  | '\127'
+  | ')'
+  | '('
+  | '<'
+  | '>'
+  | '@'
+  | ','
+  | ';'
+  | ':'
+  | '"'
+  | '/'
+  | '['
+  | ']'
+  | '?'
+  | '='
+  | '{'
+  | '}'
+  | ' ' -> false
+  | _s -> true
+
+let ows = skip is_space <|> return ()
+let token = take_while1 is_token
+let sep_by1_comma value_parser = sep_by1 (char ',') value_parser <* end_of_input
+
+let eval_parser parser default_value = function
+  | None -> [(1000, default_value)]
+  | Some str -> (
+    match parse_string ~consume:Angstrom.Consume.All parser str with
+    | Ok v -> v
+    | Error msg -> failwith msg)
+
+(** Parser for header parameters like defined in rfc
+       https://tools.ietf.org/html/rfc7231#section-5.3.2 *)
+type param =
+  | Q of int
+  | Kv of p
+
+let q_of_string s = truncate (1000. *. float_of_string s)
+
+(* More restrictive than cohttp counterpart *)
+let qs = char '"' *> token <* char '"'
+
+(* a header parameter can be : OWS ; OWS q=[value] OWS ; OWS [name]=[value] OWS
+   ; OWS [name]="[value]" *)
+let param : param t =
+  ows
+  *> char ';'
+  *> ows
+  *> (* OWS ; OWS q=[value] OWS ; OWS [name]=[value]*)
+  (lift2
+     (fun n v -> if n = "q" then Q (q_of_string v) else Kv (n, v))
+     token
+     (char '=' *> token)
+  <|> (* OWS ; OWS [name]="[value]" *)
+  lift2 (fun n v -> Kv (n, v)) token (char '=' *> qs))
+
+let params = many param
+
+let rec get_q params =
+  match params with
+  | [] -> 1000
+  | Q q :: _ -> q
+  | _ :: r -> get_q r
+
+(** Parser for values of Accept-encoding header. Example: Accept-Encoding:
+       compress, gzip Accept-Encoding: Accept-Encoding: * Accept-Encoding:
+       compress;q=0.5, gzip;q=1.0 Accept-Encoding: gzip;q=1.0, identity; q=0.5,
+       *;q=0 *)
+let encoding_value_parser =
+  ows
+  *> (char '*' *> return (Any : encoding)
+     <|> lift
+           (fun s ->
+             match String.lowercase_ascii s with
+             | "gzip" -> Gzip
+             | "compress" -> Compress
+             | "deflate" -> Deflate
+             | "identity" -> Identity
+             | enc -> Encoding enc)
+           token)
+
+let encoding_parser =
+  lift2 (fun value q -> (q, value)) encoding_value_parser (lift get_q params)
+
+let encodings_parser = sep_by1_comma encoding_parser
+let encodings = eval_parser encodings_parser Any
+
+(** Other functions (from Cohttp.Accept) *)
+let rec string_of_pl = function
+  | [] -> ""
+  | (k, v) :: r ->
+    let e = Stringext.quote v in
+    if v = e then
+      sprintf ";%s=%s%s" k v (string_of_pl r)
+    else
+      sprintf ";%s=\"%s\"%s" k e (string_of_pl r)
+
+let string_of_q = function
+  | q when q < 0 -> invalid_arg (Printf.sprintf "qvalue %d must be positive" q)
+  | q when q > 1000 ->
+    invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q)
+  | 1000 -> "1"
+  | q -> Printf.sprintf "0.%03d" q
+
+let accept_el ?q el pl =
+  match q with
+  | Some q -> sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl)
+  | None -> el
+
+let string_of_encoding ?q = function
+  | Encoding e -> accept_el ?q e []
+  | Gzip -> accept_el ?q "gzip" []
+  | Compress -> accept_el ?q "compress" []
+  | Deflate -> accept_el ?q "deflate" []
+  | Identity -> accept_el ?q "identity" []
+  | Any -> accept_el ?q "*" []
+
+let string_of_list s_of_el =
+  let rec aux s = function
+    | [(q, el)] -> s ^ s_of_el el q
+    | [] -> s
+    | (q, el) :: r -> aux (s ^ s_of_el el q ^ ",") r
+  in
+  aux ""
+
+let string_of_encodings = string_of_list (fun el q -> string_of_encoding ~q el)
+
+let qsort l =
+  let compare ((i : int), _) (i', _) = compare i' i in
+  List.stable_sort compare l

src/server/accept.mli

@@ -0,0 +1,41 @@
+(* From https://github.com/lyrm/ocaml-httpadapter/blob/master/src/http.mli
+
+   Copyright (c) 2019 Carine Morel <[email protected]>
+
+   Permission to use, copy, modify, and distribute this software for any purpose
+   with or without fee is hereby granted, provided that the above copyright
+   notice and this permission notice appear in all copies.
+
+   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+   REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+   AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+   INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+   LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+   OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+   PERFORMANCE OF THIS SOFTWARE. *)
+
+type p = string * string
+
+type encoding =
+  | Encoding of string
+  | Gzip
+  | Compress
+  | Deflate
+  | Identity
+  | Any
+
+(** Accept-Encoding HTTP header parsing and generation *)
+
+type q = int
+(** Qualities are integers between 0 and 1000. A header with ["q=0.7"]
+    corresponds to a quality of [700]. *)
+
+type 'a qlist = (q * 'a) list
+(** Lists, annotated with qualities. *)
+
+val qsort : 'a qlist -> 'a qlist
+(** Sort by quality, biggest first. Respect the initial ordering. *)
+
+val encodings : string option -> encoding qlist
+val string_of_encoding : ?q:q -> encoding -> string
+val string_of_encodings : encoding qlist -> string

src/server/dune

@@ -2,6 +2,8 @@
  (public_name dream.server)
  (name dream__server)
  (libraries
+  decompress.de
+  decompress.gz
   digestif
   dream.cipher
   dream-pure