├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── dream-encoding.opam ├── dream-encoding.opam.template ├── dune-project ├── example ├── dune ├── server.ml └── server.mli └── lib ├── accept.ml ├── accept.mli ├── dream_encoding.ml ├── dream_encoding.mli └── dune /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | jobs: 11 | build: 12 | name: Build and test 13 | 14 | runs-on: ${{ matrix.os }} 15 | 16 | strategy: 17 | fail-fast: false 18 | matrix: 19 | os: 20 | - macos-latest 21 | - ubuntu-latest 22 | ocaml-compiler: 23 | - ocaml-base-compiler.4.12.0 24 | 25 | steps: 26 | - name: Checkout code 27 | uses: actions/checkout@v2 28 | 29 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 30 | uses: avsm/setup-ocaml@v2 31 | with: 32 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 33 | dune-cache: ${{ matrix.os != 'macos-latest' }} 34 | opam-depext-flags: --with-test 35 | 36 | - run: opam install . --deps-only --with-test 37 | 38 | - run: make build 39 | 40 | lint-opam: 41 | strategy: 42 | matrix: 43 | ocaml-compiler: 44 | - ocaml-base-compiler.4.12.0 45 | 46 | runs-on: ubuntu-latest 47 | 48 | steps: 49 | - name: Checkout code 50 | uses: actions/checkout@v2 51 | 52 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 53 | uses: avsm/setup-ocaml@v2 54 | with: 55 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 56 | dune-cache: true 57 | 58 | - run: opam depext opam-dune-lint --install 59 | 60 | - run: opam install . --deps-only 61 | 62 | - run: make build 63 | 64 | - run: opam exec -- opam-dune-lint 65 | 66 | lint-fmt: 67 | strategy: 68 | matrix: 69 | ocaml-compiler: 70 | - ocaml-base-compiler.4.12.0 71 | 72 | runs-on: ubuntu-latest 73 | 74 | steps: 75 | - name: Checkout code 76 | uses: actions/checkout@v2 77 | 78 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 79 | uses: avsm/setup-ocaml@v2 80 | with: 81 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 82 | dune-cache: true 83 | 84 | - run: opam depext ocamlformat --install 85 | 86 | - run: opam install . --deps-only 87 | 88 | - run: make fmt -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ocamlbuild working directory 2 | _build/ 3 | 4 | # ocamlbuild targets 5 | *.byte 6 | *.native 7 | 8 | # Merlin configuring file for Vim and Emacs 9 | .merlin 10 | 11 | # Dune generated files 12 | *.install 13 | 14 | # Local OPAM switch 15 | _opam/ 16 | 17 | # Normal npm stuff 18 | npm-debug.log 19 | yarn-error.log 20 | node_modules/ 21 | .cache/ 22 | dist/ 23 | build/ 24 | 25 | # IDE related 26 | .vscode* 27 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.21.0 2 | profile = default 3 | parse-docstrings = true 4 | wrap-comments = true -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.3.0 2 | 3 | - Discard encoding with priority 0 (#3 by @samoht) 4 | - Use a sub_log and log at debug level (#2 by @beajeanm) 5 | 6 | # 0.2.0 7 | 8 | - Support for dream.1.0.0~alpha3 9 | 10 | # 0.1.0 11 | 12 | - Initial release 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC License (ISC) 2 | Copyright (c) 2021, Thibaut Mattio 3 | 4 | Permission to use, copy, modify, and/or 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. 5 | 6 | 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. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT_GOAL := all 2 | 3 | .PHONY: all 4 | all: 5 | opam exec -- dune build --root . @install 6 | 7 | .PHONY: deps 8 | deps: ## Install development dependencies 9 | opam install -y dune-release ocamlformat utop ocaml-lsp-server 10 | opam install --deps-only --with-test --with-doc -y . 11 | 12 | .PHONY: create_switch 13 | create_switch: 14 | opam switch create . --no-install 15 | 16 | .PHONY: switch 17 | switch: create_switch deps ## Create an opam switch and install development dependencies 18 | 19 | .PHONY: lock 20 | lock: ## Generate a lock file 21 | opam lock -y . 22 | 23 | .PHONY: build 24 | build: ## Build the project, including non installable libraries and executables 25 | opam exec -- dune build --root . 26 | 27 | .PHONY: install 28 | install: all ## Install the packages on the system 29 | opam exec -- dune install --root . 30 | 31 | .PHONY: example 32 | example: all ## Run the produced executable 33 | opam exec -- dune exec --root . example/server.exe 34 | 35 | .PHONY: test 36 | test: ## Run the unit tests 37 | opam exec -- dune test --root . 38 | 39 | .PHONY: clean 40 | clean: ## Clean build artifacts and other generated files 41 | opam exec -- dune clean --root . 42 | 43 | .PHONY: doc 44 | doc: ## Generate odoc documentation 45 | opam exec -- dune build --root . @doc 46 | 47 | .PHONY: fmt 48 | fmt: ## Format the codebase with ocamlformat 49 | opam exec -- dune build --root . --auto-promote @fmt 50 | 51 | .PHONY: watch 52 | watch: ## Watch for the filesystem and rebuild on every change 53 | opam exec -- dune build -w 54 | 55 | .PHONY: utop 56 | utop: ## Run a REPL and link with the project's libraries 57 | opam exec -- dune utop --root . lib -- -implicit-bindings 58 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Dream Encoding 2 | 3 | [![Actions Status](https://github.com/tmattio/dream-encoding/workflows/CI/badge.svg)](https://github.com/tmattio/dream-encoding/actions) 4 | 5 | Encoding primitives for Dream. 6 | 7 | ## Usage 8 | 9 | The most common usage is to add the `Dream_encoding.compress` middleware to your Dream application: 10 | 11 | ```ocaml 12 | let () = 13 | Dream.run ~debug:true 14 | @@ Dream.logger 15 | @@ Dream_encoding.compress 16 | @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Hello World!") ] 17 | @@ Dream.not_found 18 | ``` 19 | 20 | The middleware will parse the `Accept-Encoding` header from the requests and compress the responses accordingly. 21 | 22 | The library API also includes other lower-level functions for convenience, and are documented [here](https://tmattio.github.io/dream-encoding/dream-encoding/Dream_encoding/index.html). 23 | 24 | ## Limitation 25 | 26 | As of now, the only supported encoding directives are `gzip` and `deflate`. 27 | 28 | Support for more compression methods will come when they are supported in `decompress`, the underlying compression library used in `dream-encoding`. 29 | 30 | ## To Do 31 | 32 | - [ ] Support Brotli compression (see https://github.com/mirage/decompress/issues/101) 33 | -------------------------------------------------------------------------------- /dream-encoding.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Encoding primitives for Dream" 4 | description: "Encoding primitives for Dream." 5 | maintainer: ["Thibaut Mattio"] 6 | authors: ["Thibaut Mattio"] 7 | license: "MIT" 8 | homepage: "https://github.com/tmattio/dream-encoding" 9 | doc: "https://tmattio.github.io/dream-encoding/" 10 | bug-reports: "https://github.com/tmattio/dream-encoding/issues" 11 | depends: [ 12 | "dune" {>= "2.7"} 13 | "ocaml" {>= "4.08.0"} 14 | "dream" {>= "1.0.0~alpha3"} 15 | "decompress" {>= "1.4.1"} 16 | "lwt_ppx" 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/tmattio/dream-encoding.git" 34 | conflicts: [ 35 | "result" {< "1.5"} # Might use result through lwt and explicitly uses Result.bind 36 | ] 37 | -------------------------------------------------------------------------------- /dream-encoding.opam.template: -------------------------------------------------------------------------------- 1 | conflicts: [ 2 | "result" {< "1.5"} # Might use result through lwt and explicitly uses Result.bind 3 | ] 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | 3 | (name dream-encoding) 4 | 5 | (documentation "https://tmattio.github.io/dream-encoding/") 6 | 7 | (source 8 | (github tmattio/dream-encoding)) 9 | 10 | (license MIT) 11 | 12 | (authors "Thibaut Mattio") 13 | 14 | (maintainers "Thibaut Mattio") 15 | 16 | (generate_opam_files true) 17 | 18 | (package 19 | (name dream-encoding) 20 | (synopsis "Encoding primitives for Dream") 21 | (description "Encoding primitives for Dream.") 22 | (depends 23 | (ocaml 24 | (>= 4.08.0)) 25 | (dream 26 | (>= 1.0.0~alpha3)) 27 | (decompress 28 | (>= 1.4.1)) 29 | lwt_ppx)) 30 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name server) 3 | (modules server) 4 | (libraries dream dream-encoding)) 5 | -------------------------------------------------------------------------------- /example/server.ml: -------------------------------------------------------------------------------- 1 | (** Main entry point for our application. *) 2 | 3 | let () = 4 | Dream.run @@ Dream.logger @@ Dream_encoding.compress 5 | @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Hello World!") ] 6 | -------------------------------------------------------------------------------- /example/server.mli: -------------------------------------------------------------------------------- 1 | (** Main entry point for our application. *) 2 | -------------------------------------------------------------------------------- /lib/accept.ml: -------------------------------------------------------------------------------- 1 | (* From 2 | https://github.com/lyrm/ocaml-httpadapter/blob/master/src-httpaf/accept.ml 3 | 4 | Copyright (c) 2019 Carine Morel 5 | 6 | Permission to use, copy, modify, and distribute this software for any purpose 7 | with or without fee is hereby granted, provided that the above copyright 8 | notice and this permission notice appear in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 11 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 12 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 13 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 14 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 15 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 16 | PERFORMANCE OF THIS SOFTWARE. *) 17 | 18 | open Angstrom 19 | open Printf 20 | 21 | type encoding = 22 | | Encoding of string 23 | | Gzip 24 | | Compress 25 | | Deflate 26 | | Identity 27 | | Any 28 | 29 | type p = string * string 30 | type q = int 31 | type 'a qlist = (q * 'a) list 32 | 33 | (** Lexer *) 34 | let is_space = function ' ' | '\t' -> true | _ -> false 35 | 36 | let is_token = function 37 | | '\000' .. '\031' 38 | | '\127' | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '"' | '/' | '[' 39 | | ']' | '?' | '=' | '{' | '}' | ' ' -> 40 | false 41 | | _s -> true 42 | 43 | let ows = skip is_space <|> return () 44 | let token = take_while1 is_token 45 | let sep_by1_comma value_parser = sep_by1 (char ',') value_parser <* end_of_input 46 | 47 | let eval_parser parser default_value = function 48 | | None -> [ (1000, default_value) ] 49 | | Some str -> ( 50 | match parse_string ~consume:Angstrom.Consume.All parser str with 51 | | Ok v -> v 52 | | Error msg -> failwith msg) 53 | 54 | (** Parser for header parameters like defined in rfc 55 | https://tools.ietf.org/html/rfc7231#section-5.3.2 *) 56 | type param = Q of int | Kv of p 57 | 58 | let q_of_string s = truncate (1000. *. float_of_string s) 59 | 60 | (* More restrictive than cohttp counterpart *) 61 | let qs = char '"' *> token <* char '"' 62 | 63 | (* a header parameter can be : OWS ; OWS q=[value] OWS ; OWS [name]=[value] OWS 64 | ; OWS [name]="[value]" *) 65 | let param : param t = 66 | ows *> char ';' *> ows 67 | *> (* OWS ; OWS q=[value] OWS ; OWS [name]=[value]*) 68 | (lift2 69 | (fun n v -> if n = "q" then Q (q_of_string v) else Kv (n, v)) 70 | token 71 | (char '=' *> token) 72 | <|> (* OWS ; OWS [name]="[value]" *) 73 | lift2 (fun n v -> Kv (n, v)) token (char '=' *> qs)) 74 | 75 | let params = many param 76 | 77 | let rec get_q params = 78 | match params with [] -> 1000 | Q q :: _ -> q | _ :: r -> get_q r 79 | 80 | (** Parser for values of Accept-encoding header. Example: Accept-Encoding: 81 | compress, gzip Accept-Encoding: Accept-Encoding: * Accept-Encoding: 82 | compress;q=0.5, gzip;q=1.0 Accept-Encoding: gzip;q=1.0, identity; q=0.5, 83 | *;q=0 *) 84 | let encoding_value_parser = 85 | ows 86 | *> (char '*' *> return (Any : encoding) 87 | <|> lift 88 | (fun s -> 89 | match String.lowercase_ascii s with 90 | | "gzip" -> Gzip 91 | | "compress" -> Compress 92 | | "deflate" -> Deflate 93 | | "identity" -> Identity 94 | | enc -> Encoding enc) 95 | token) 96 | 97 | let encoding_parser = 98 | lift2 (fun value q -> (q, value)) encoding_value_parser (lift get_q params) 99 | 100 | let encodings_parser = sep_by1_comma encoding_parser 101 | let encodings = eval_parser encodings_parser Any 102 | 103 | (** Other functions (from Cohttp.Accept) *) 104 | let rec string_of_pl = function 105 | | [] -> "" 106 | | (k, v) :: r -> 107 | let e = Stringext.quote v in 108 | if v = e then sprintf ";%s=%s%s" k v (string_of_pl r) 109 | else sprintf ";%s=\"%s\"%s" k e (string_of_pl r) 110 | 111 | let string_of_q = function 112 | | q when q < 0 -> invalid_arg (Printf.sprintf "qvalue %d must be positive" q) 113 | | q when q > 1000 -> 114 | invalid_arg (Printf.sprintf "qvalue %d must be less than 1000" q) 115 | | 1000 -> "1" 116 | | q -> Printf.sprintf "0.%03d" q 117 | 118 | let accept_el ?q el pl = 119 | match q with 120 | | Some q -> sprintf "%s;q=%s%s" el (string_of_q q) (string_of_pl pl) 121 | | None -> el 122 | 123 | let string_of_encoding ?q = function 124 | | Encoding e -> accept_el ?q e [] 125 | | Gzip -> accept_el ?q "gzip" [] 126 | | Compress -> accept_el ?q "compress" [] 127 | | Deflate -> accept_el ?q "deflate" [] 128 | | Identity -> accept_el ?q "identity" [] 129 | | Any -> accept_el ?q "*" [] 130 | 131 | let string_of_list s_of_el = 132 | let rec aux s = function 133 | | [ (q, el) ] -> s ^ s_of_el el q 134 | | [] -> s 135 | | (q, el) :: r -> aux (s ^ s_of_el el q ^ ",") r 136 | in 137 | aux "" 138 | 139 | let string_of_encodings = string_of_list (fun el q -> string_of_encoding ~q el) 140 | 141 | let qsort l = 142 | let compare ((i : int), _) (i', _) = compare i' i in 143 | List.stable_sort compare l 144 | -------------------------------------------------------------------------------- /lib/accept.mli: -------------------------------------------------------------------------------- 1 | (* From https://github.com/lyrm/ocaml-httpadapter/blob/master/src/http.mli 2 | 3 | Copyright (c) 2019 Carine Morel 4 | 5 | Permission to use, copy, modify, and distribute this software for any purpose 6 | with or without fee is hereby granted, provided that the above copyright 7 | notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 10 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 11 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 13 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 14 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. *) 16 | 17 | type p = string * string 18 | 19 | type encoding = 20 | | Encoding of string 21 | | Gzip 22 | | Compress 23 | | Deflate 24 | | Identity 25 | | Any 26 | 27 | (** Accept-Encoding HTTP header parsing and generation *) 28 | 29 | type q = int 30 | (** Qualities are integers between 0 and 1000. A header with ["q=0.7"] 31 | corresponds to a quality of [700]. *) 32 | 33 | type 'a qlist = (q * 'a) list 34 | (** Lists, annotated with qualities. *) 35 | 36 | val qsort : 'a qlist -> 'a qlist 37 | (** Sort by quality, biggest first. Respect the initial ordering. *) 38 | 39 | val encodings : string option -> encoding qlist 40 | val string_of_encoding : ?q:q -> encoding -> string 41 | val string_of_encodings : encoding qlist -> string 42 | -------------------------------------------------------------------------------- /lib/dream_encoding.ml: -------------------------------------------------------------------------------- 1 | let inflate_string_de str = 2 | let i = De.bigstring_create De.io_buffer_size in 3 | let o = De.bigstring_create De.io_buffer_size in 4 | let w = De.make_window ~bits:15 in 5 | let r = Buffer.create 0x1000 in 6 | let p = ref 0 in 7 | let refill buf = 8 | let len = min (String.length str - !p) De.io_buffer_size in 9 | Bigstringaf.blit_from_string str ~src_off:!p buf ~dst_off:0 ~len; 10 | p := !p + len; 11 | len 12 | in 13 | let flush buf len = 14 | let str = Bigstringaf.substring buf ~off:0 ~len in 15 | Buffer.add_string r str 16 | in 17 | match De.Higher.uncompress ~w ~refill ~flush i o with 18 | | Ok () -> Ok (Buffer.contents r) 19 | | Error _ as err -> err 20 | 21 | let deflate_string_de str = 22 | let i = De.bigstring_create De.io_buffer_size in 23 | let o = De.bigstring_create De.io_buffer_size in 24 | let w = De.Lz77.make_window ~bits:15 in 25 | let q = De.Queue.create 0x1000 in 26 | let r = Buffer.create 0x1000 in 27 | let p = ref 0 in 28 | let refill buf = 29 | (* assert (buf == i); *) 30 | let len = min (String.length str - !p) De.io_buffer_size in 31 | Bigstringaf.blit_from_string str ~src_off:!p buf ~dst_off:0 ~len; 32 | p := !p + len; 33 | len 34 | in 35 | let flush buf len = 36 | (* assert (buf == o); *) 37 | let str = Bigstringaf.substring buf ~off:0 ~len in 38 | Buffer.add_string r str 39 | in 40 | De.Higher.compress ~w ~q ~refill ~flush i o; 41 | Buffer.contents r 42 | 43 | let inflate_string_gz str = 44 | let i = De.bigstring_create De.io_buffer_size in 45 | let o = De.bigstring_create De.io_buffer_size in 46 | let r = Buffer.create 0x1000 in 47 | let p = ref 0 in 48 | let refill buf = 49 | let len = min (String.length str - !p) De.io_buffer_size in 50 | Bigstringaf.blit_from_string str ~src_off:!p buf ~dst_off:0 ~len; 51 | p := !p + len; 52 | len 53 | in 54 | let flush buf len = 55 | let str = Bigstringaf.substring buf ~off:0 ~len in 56 | Buffer.add_string r str 57 | in 58 | match Gz.Higher.uncompress ~refill ~flush i o with 59 | | Ok _ -> Ok (Buffer.contents r) 60 | | Error _ as err -> err 61 | 62 | let time () = Int32.of_float (Unix.gettimeofday ()) 63 | 64 | let deflate_string_gz ?(level = 4) str = 65 | let i = De.bigstring_create De.io_buffer_size in 66 | let o = De.bigstring_create De.io_buffer_size in 67 | let w = De.Lz77.make_window ~bits:15 in 68 | let q = De.Queue.create 0x1000 in 69 | let r = Buffer.create 0x1000 in 70 | let p = ref 0 in 71 | let cfg = Gz.Higher.configuration Gz.Unix time in 72 | let refill buf = 73 | let len = min (String.length str - !p) De.io_buffer_size in 74 | Bigstringaf.blit_from_string str ~src_off:!p buf ~dst_off:0 ~len; 75 | p := !p + len; 76 | len 77 | in 78 | let flush buf len = 79 | let str = Bigstringaf.substring buf ~off:0 ~len in 80 | Buffer.add_string r str 81 | in 82 | Gz.Higher.compress ~w ~q ~level ~refill ~flush () cfg i o; 83 | Buffer.contents r 84 | 85 | let inflate_string ~algorithm str = 86 | match algorithm with 87 | | `Deflate -> inflate_string_de str 88 | | `Gzip -> inflate_string_gz str 89 | 90 | let deflate_string ~algorithm str = 91 | match algorithm with 92 | | `Deflate -> deflate_string_de str 93 | | `Gzip -> deflate_string_gz str 94 | 95 | let encoding_of_string = function 96 | | "deflate" -> `Deflate 97 | | "gzip" -> `Gzip 98 | | s -> `Unknown s 99 | 100 | let content_encodings request = 101 | match Dream.header request "content-encoding" with 102 | | None -> None 103 | | Some s -> 104 | String.split_on_char ',' s 105 | |> List.map (fun x -> x |> String.trim |> String.lowercase_ascii) 106 | |> List.map encoding_of_string 107 | |> Option.some 108 | 109 | let accepted_encodings_with_weights request = 110 | match Dream.header request "accept-encoding" with 111 | | None -> None 112 | | Some s -> 113 | let encodings = Accept.encodings (Some s) |> Accept.qsort in 114 | Some 115 | (List.map 116 | (fun (a, b) -> 117 | ( (match b with 118 | | Accept.Any -> `Any 119 | | Accept.Gzip -> `Gzip 120 | | Accept.Compress -> `Compress 121 | | Accept.Deflate -> `Deflate 122 | | Accept.Identity -> `Identity 123 | | Accept.Encoding s -> `Unknown s), 124 | a )) 125 | encodings) 126 | 127 | let accepted_encodings request = 128 | match accepted_encodings_with_weights request with 129 | | None -> None 130 | | Some encodings -> 131 | Some 132 | (List.filter_map (function _, 0 -> None | a, _ -> Some a) encodings) 133 | 134 | let preferred_content_encoding request = 135 | match accepted_encodings request with 136 | | None -> None 137 | | Some l -> 138 | let rec aux = function 139 | | [] -> None 140 | | `Any :: _rest -> Some `Gzip 141 | | `Deflate :: _rest -> Some `Deflate 142 | | `Gzip :: _rest -> Some `Gzip 143 | | _ :: rest -> aux rest 144 | in 145 | aux l 146 | 147 | let algorithm_to_string = function `Deflate -> "deflate" | `Gzip -> "gzip" 148 | 149 | let with_encoded_body ?(algorithm = `Deflate) body response = 150 | match body with 151 | | "" -> response 152 | | _ -> 153 | let encoded_body = deflate_string ~algorithm body in 154 | Dream.set_body response encoded_body; 155 | Dream.set_header response "Content-Encoding" 156 | (algorithm_to_string algorithm); 157 | response 158 | 159 | let log = Dream.sub_log "dream.encoding" 160 | 161 | let compress handler req = 162 | let%lwt response = handler req in 163 | let preferred_algorithm = preferred_content_encoding req in 164 | match preferred_algorithm with 165 | | None -> Lwt.return response 166 | | Some algorithm -> 167 | log.debug (fun log -> 168 | log "Compressing request with algorithm: %s" 169 | (algorithm_to_string algorithm)); 170 | let%lwt body = Dream.body response in 171 | Lwt.return @@ with_encoded_body ~algorithm body response 172 | 173 | let decompress handler req = 174 | let rec aux algorithms content = 175 | match algorithms with 176 | | [] -> Ok content 177 | | (`Deflate as el) :: rest | (`Gzip as el) :: rest -> 178 | Result.bind (inflate_string ~algorithm:el content) (aux rest) 179 | | _ :: _rest -> Error (`Msg "Unsopported encoding directive") 180 | in 181 | let algorithms = content_encodings req in 182 | match algorithms with 183 | | None -> handler req 184 | | Some algorithms -> ( 185 | let%lwt body = Dream.body req in 186 | let body = aux algorithms body in 187 | match body with 188 | | Ok body -> 189 | Dream.set_body req body; 190 | handler req 191 | | Error (`Msg err) -> Dream.respond ~status:`Unsupported_Media_Type err) 192 | -------------------------------------------------------------------------------- /lib/dream_encoding.mli: -------------------------------------------------------------------------------- 1 | (** Encoding primitives for Dream. 2 | 3 | The main use case for this library is to compress the response body of a 4 | given list of endpoints. To do this, you can simply add 5 | [Dream_encoding.compress] to your list of middlewares: 6 | 7 | {[ 8 | let () = 9 | Dream.run @@ Dream.logger @@ Dream_encoding.compress 10 | @@ Dream.router [ Dream.get "/" (fun _ -> Dream.html "Hello World!") ] 11 | @@ Dream.not_found 12 | ]} 13 | 14 | For more advanced use cases, some utility functions are also exposed. In 15 | particular, functions to retrieve the [Content-Encoding] and 16 | [Accept-Encoding] headers (respectively, [content_encoding] and 17 | [accept_encoding]), as well as [with_encoded_body], a function to compress 18 | the body of a response. 19 | 20 | As of now, the supported encoding directives are [deflate] and [gzip]. More 21 | directive will be supported when their support land in [decompress], the 22 | underlying compression library used by Dream_encoding. *) 23 | 24 | val compress : Dream.middleware 25 | (** Middleware that reads the [Accept-Encoding] header of the request and 26 | compresses the responses with the preferred supported algorithm. *) 27 | 28 | val decompress : Dream.middleware 29 | (** Middleware that reads the [Content-Encoding] of the request and decompresses 30 | the body if all of the directives of the header are supported. 31 | 32 | If one or more of the directive is not supported, an HTTP response 33 | [415 Unsupported Media Type] is returned to the client. 34 | 35 | Note that although HTTP supports encoding requests, it is rarely used in 36 | practice. See [compress] to for a middleware that compresses the responses 37 | instead. *) 38 | 39 | val with_encoded_body : 40 | ?algorithm:[ `Deflate | `Gzip ] -> string -> Dream.response -> Dream.response 41 | (** [with_encoded_body ?algorithm body response] replaces the body of the 42 | response with [body] compressed with [algorithm] and adds the corresponding 43 | [Content-Encoding] header. 44 | 45 | [algorithm] defaults to [`Deflate]. *) 46 | 47 | val accepted_encodings : 48 | 'a Dream.message -> 49 | [ `Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string ] list 50 | option 51 | (** Retrieve the list of accepted encoding directives from the [Accept-Encoding] 52 | header, ordered by quality weight in decreasing order. 53 | 54 | If the request does not have an [Accept-Encoding] header, this returns 55 | [None]. *) 56 | 57 | val accepted_encodings_with_weights : 58 | 'a Dream.message -> 59 | ([ `Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string ] 60 | * int) 61 | list 62 | option 63 | (** Same as [accepted_encoding], but returns the quality weights associated to 64 | the encoding directive. *) 65 | 66 | val content_encodings : 67 | 'a Dream.message -> 68 | [ `Gzip | `Compress | `Deflate | `Identity | `Any | `Unknown of string ] list 69 | option 70 | (** Retrieve the list of content encoding directives from the [Content-Encoding] 71 | header. 72 | 73 | If the request does not have an [Content-Encoding] header, this returns 74 | [None]. *) 75 | 76 | val preferred_content_encoding : 'a Dream.message -> [ `Deflate | `Gzip ] option 77 | (** Retrieve preferred encoding directive from the [Accept-Encoding]. 78 | 79 | The preferred encoding directive is the first supported algorithm in the 80 | list of accepted directives sorted by quality weight. 81 | 82 | If [*] is given as the preferred encoding, [`Gzip] is returned. This is to 83 | be on par with the behavior of [compress]. 84 | 85 | If no algorithm is supported, or if the request does not have an 86 | [Accept-Encoding] header, this returns [None]. *) 87 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dream_encoding) 3 | (public_name dream-encoding) 4 | (libraries dream decompress.de decompress.gz) 5 | (preprocess 6 | (pps lwt_ppx))) 7 | --------------------------------------------------------------------------------