├── .gitattributes ├── .github └── workflows │ ├── changelog.yml │ └── ci.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.cpp.md ├── README.md ├── benchmark ├── README.md ├── result │ ├── histogram.png │ ├── httpaf.log │ └── opium.log ├── run.sh └── src │ ├── dune │ ├── httpaf.ml │ └── opium.ml ├── default.nix ├── dune ├── dune-project ├── dune-workspace.dev ├── example ├── README.md ├── dune ├── exit_hook │ ├── README.md │ ├── dune │ └── main.ml ├── file_upload │ ├── README.md │ ├── dune │ ├── main.ml │ └── simple.ml ├── graphql │ ├── README.md │ ├── dune │ └── main.ml ├── hello_world │ ├── README.md │ ├── dune │ └── main.ml ├── html_response │ ├── README.md │ ├── dune │ ├── main.ml │ └── view.ml ├── json_request │ ├── README.md │ ├── dune │ └── main.ml ├── json_response │ ├── README.md │ ├── dune │ └── main.ml ├── rock_server │ ├── README.md │ ├── dune │ └── main.ml ├── simple_middleware │ ├── README.md │ ├── dune │ └── main.ml ├── static_serve │ ├── README.md │ ├── asset │ │ ├── favicon.ico │ │ └── robots.txt │ ├── dune │ └── main.ml └── user_auth │ ├── README.md │ ├── dune │ └── main.ml ├── nix ├── default.nix ├── opam-selection.nix └── opam2nix.nix ├── opium-graphql.opam ├── opium-graphql ├── asset │ └── graphiql.html ├── doc │ ├── dune │ └── index.mld ├── src │ ├── dune │ ├── opium_graphql.ml │ └── opium_graphql.mli └── test │ ├── dune │ └── request_test.ml ├── opium-testing.opam ├── opium-testing ├── doc │ ├── dune │ └── index.mld └── src │ ├── dune │ ├── opium_testing.ml │ └── opium_testing.mli ├── opium.opam ├── opium ├── doc │ ├── dune │ └── index.mld ├── src │ ├── app.ml │ ├── app.mli │ ├── auth.ml │ ├── auth.mli │ ├── body.ml │ ├── body.mli │ ├── context.ml │ ├── context.mli │ ├── cookie.ml │ ├── cookie.mli │ ├── dune │ ├── handlers │ │ ├── handler_serve.ml │ │ └── handler_serve.mli │ ├── headers.ml │ ├── headers.mli │ ├── import.ml │ ├── method.ml │ ├── method.mli │ ├── middlewares │ │ ├── middleware_allow_cors.ml │ │ ├── middleware_allow_cors.mli │ │ ├── middleware_basic_auth.ml │ │ ├── middleware_basic_auth.mli │ │ ├── middleware_content_length.ml │ │ ├── middleware_content_length.mli │ │ ├── middleware_debugger.ml │ │ ├── middleware_debugger.mli │ │ ├── middleware_etag.ml │ │ ├── middleware_etag.mli │ │ ├── middleware_head.ml │ │ ├── middleware_head.mli │ │ ├── middleware_logger.ml │ │ ├── middleware_logger.mli │ │ ├── middleware_method_override.ml │ │ ├── middleware_method_override.mli │ │ ├── middleware_method_required.ml │ │ ├── middleware_method_required.mli │ │ ├── middleware_router.ml │ │ ├── middleware_router.mli │ │ ├── middleware_static.ml │ │ ├── middleware_static.mli │ │ ├── middleware_static_unix.ml │ │ └── middleware_static_unix.mli │ ├── nifty.ml │ ├── opium.ml │ ├── opium.mli │ ├── request.ml │ ├── request.mli │ ├── response.ml │ ├── response.mli │ ├── route.ml │ ├── route.mli │ ├── status.ml │ ├── status.mli │ ├── version.ml │ └── version.mli └── test │ ├── cookie.ml │ ├── dune │ ├── middleware_allow_cors.ml │ ├── request.ml │ ├── response.ml │ └── route.ml ├── rock.opam ├── rock ├── doc │ ├── dune │ └── index.mld └── src │ ├── app.ml │ ├── app.mli │ ├── body.ml │ ├── body.mli │ ├── context.ml │ ├── context.mli │ ├── dune │ ├── filter.ml │ ├── filter.mli │ ├── handler.ml │ ├── handler.mli │ ├── middleware.ml │ ├── middleware.mli │ ├── request.ml │ ├── request.mli │ ├── response.ml │ ├── response.mli │ ├── rock.ml │ ├── rock.mli │ ├── server_connection.ml │ ├── server_connection.mli │ ├── service.ml │ └── service.mli └── shell.nix /.gitattributes: -------------------------------------------------------------------------------- 1 | nix/opam-selection.nix linguist-generated=true 2 | -------------------------------------------------------------------------------- /.github/workflows/changelog.yml: -------------------------------------------------------------------------------- 1 | name: Changelog 2 | 3 | on: 4 | pull_request: 5 | branches: [ master ] 6 | types: [ opened, synchronize, reopened, labeled, unlabeled ] 7 | 8 | jobs: 9 | build: 10 | name: Check changelog entry 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - name: Checkout code 16 | uses: actions/checkout@v1 17 | 18 | - name: Check CHANGES.md changed 19 | if: ${{ !contains(github.event.pull_request.labels.*.name, 'no changelog') }} 20 | env: 21 | BASE_REF: ${{ github.event.pull_request.base.ref }} 22 | run: | 23 | ! git diff --exit-code origin/$BASE_REF -- CHANGES.md 24 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | build: 7 | name: Build and test 8 | 9 | runs-on: ${{ matrix.os }} 10 | 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - macos-latest 16 | - ubuntu-latest 17 | - windows-latest 18 | ocaml-compiler: 19 | - 4.13.x 20 | include: 21 | - os: ubuntu-latest 22 | ocaml-compiler: 4.08.x 23 | 24 | steps: 25 | - name: Checkout code 26 | uses: actions/checkout@v2 27 | 28 | - name: Use OCaml ${{ matrix.ocaml-version }} 29 | uses: ocaml/setup-ocaml@v2 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | dune-cache: ${{ matrix.os != 'macos-latest' }} 33 | opam-depext-flags: --with-test 34 | 35 | - run: opam install . --deps-only --with-test 36 | 37 | - name: Run tests 38 | run: make test 39 | 40 | - name: Build examples 41 | run: opam exec -- dune build @example 42 | -------------------------------------------------------------------------------- /.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 | # Nix-build geenrated artifact 18 | result 19 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet 2 | parse-docstrings = true 3 | wrap-comments = true 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Unreleased 2 | 3 | ## Added 4 | 5 | - Change type signature of static and static_unix middlewares to get ETag as promise. 6 | - Make static_unix middleware derive ETag from file modification timestamp. 7 | - `App.debug` and `App.verbose` 8 | - Give access to client's sockaddr from within an Opium handler 9 | 10 | ## Fixed 11 | 12 | - Fix Fullsplat behavior (routes with `**`) 13 | - Undo splat reverse order. Now, the matches for `/*/*/*` with the url `/a/b/c` will return `["a"; "b"; "c"]` 14 | - deprecated `Term` commands 15 | 16 | ## Changed 17 | 18 | - Update various opium-testing apis to avoid raising warning 16 19 | - replacing `mirage-crypto` with `digestif`, because `mirage-crypto` doesn't provide `md5` and `sha1` anymore 20 | 21 | # 0.20.0 22 | 23 | ## Added 24 | 25 | - New `Auth` module to work with `Authorization` header (#238) 26 | - New `basic_auth` middleware to protect handlers with a `Basic` authentication method (#238) 27 | - New `Response.of_file` API for conveniently creating a response of a file (#244) 28 | - Add a package `opium-graphql` to easily create GraphQL server with Opium (#235) 29 | - Add a function `App.run_multicore` that uses pre-forking and spawns multiple processes that will handle incoming requests (#239) 30 | 31 | ## Fixed 32 | 33 | - Fix reading cookie values when multiple cookies are present in `Cookie` header (#246) 34 | 35 | # 0.19.0 36 | 37 | This release is a complete rewrite of the Opium's internal that switches from Cohttp to Httpaf. 38 | As demonstrated in several benchmarks, Httpaf's latency is much lower than Cohttp's in stress tests, so it is expected that Opium will perform better in these high pressure situations with this change. 39 | 40 | The underlying HTTP server implementation is now contained in the `rock` package, that provides a Service and Filter implementation, inspired by Finagle's. The architecture is similar to Ruby's Rack library (hence the name), so one can compose complex web applications by combining Rock applications. 41 | 42 | The `rock` package offers a very slim API, with very few dependencies, so it should be an attractive option for other Web framework to build on, which would allow the re-usability of middlewares and handlers, independently of the framework used (e.g. one could use Sihl middlewares with Opium, and vice versa). 43 | 44 | Apart from the architectural changes, this release comes with a lot of additionnal utilities and middlewares which should make Opium a better candidate for complex web applications, without having to re-write a lot of common Web server functionnalities. 45 | 46 | The Request and Response modules now provide: 47 | 48 | - JSON encoders/decoders with `Yojson` 49 | - HTML encoders/decoders with `Tyxml` 50 | - XML encoders/decoders with `Tyxml` 51 | - SVG encoders/decoders with `Tyxml` 52 | - multipart/form encoders/decoders with `multipart_form_data` 53 | - urlencoded encoders/decoders with `Uri` 54 | 55 | And the following middlewares are now built-in: 56 | 57 | - `debugger` to display an HTML page with the errors in case of failures 58 | - `logger` to log requests and responses, with a timer 59 | - `allow_cors` to add CORS headers 60 | - `static` to serve static content given a custom read function (e.g. read from S3) 61 | - `static_unix` to to serve static content from the local filesystem 62 | - `content_length` to add the `Content-Length` header to responses 63 | - `method_override` to replace the HTTP method with the one found in the `_method` field of `application/x-www-form-urlencoded` encoded `POST` requests. 64 | - `etag` to add `ETag` header to the responses and send an HTTP code `304` when the computed ETag matches the one specified in the request. 65 | - `method_required` to filter the requests by method and respond with an HTTP code `405` if the method is not allowed. 66 | - `head` to add supports for `HEAD` request for handlers that receive `GET` requests. 67 | 68 | Lastly, this release also adds a package `opium-testing` that can be used to test Opium applications with `Alcotest`. It provides `Testable` modules for every Opium types, and implements helper functions to easily get an `Opium.Response` from an `Opium.Request`. 69 | 70 | # 0.18.0 71 | 72 | * Make examples easier to find and add documentation related to features used in them. (#125, @shonfeder) 73 | * Allow overriding 404 handlers (#127, @anuragsoni) 74 | * Support cohttp streaming response (#135, #137, #139, @anuragsoni) 75 | 76 | # v0.17.1 77 | 78 | * Change Deferred.t to Lwt.t in readme (#91, @rymdhund) 79 | * Remove `cow` from deps (#92, @anuragsoni) 80 | 81 | # v0.17.0 82 | 83 | * Switch to dune (#88, @anuragsoni) 84 | * Keep the "/" cookie default and expose all cookie directives (#82, @actionshrimp) 85 | * Do not assume base 64 encoding of cookies (#74, @malthe) 86 | * Add caching capabilities to middleware (#76, @mattjbray) 87 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Rudi Grinberg 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT_GOAL := help 2 | 3 | PREFIX_ARG := $(if $(PREFIX),--prefix $(PREFIX),) 4 | LIBDIR_ARG := $(if $(LIBDIR),--libdir $(LIBDIR),) 5 | DESTDIR_ARG := $(if $(DESTDIR),--destdir $(DESTDIR),) 6 | INSTALL_ARGS := $(PREFIX_ARG) $(LIBDIR_ARG) $(DESTDIR_ARG) 7 | 8 | define BROWSER_PYSCRIPT 9 | import os, webbrowser, sys 10 | 11 | from urllib.request import pathname2url 12 | 13 | webbrowser.open("file://" + pathname2url(os.path.abspath(sys.argv[1]))) 14 | endef 15 | export BROWSER_PYSCRIPT 16 | 17 | BROWSER := python -c "$$BROWSER_PYSCRIPT" 18 | 19 | -include Makefile.dev 20 | 21 | .PHONY: help 22 | help: ## Print the help message 23 | @echo "Welcome to Opium!" 24 | @echo "=================" 25 | @echo "" 26 | @echo "Here are the commands you can use:" 27 | @echo "" 28 | @echo "- build to build the project, including non installable libraries and executables" 29 | @echo "- test to run the unit tests" 30 | @echo "- doc to generate odoc documentation" 31 | @echo "- servedoc to open odoc documentation with default web browser" 32 | @echo "- release to release the latest version" 33 | 34 | .PHONY: all 35 | all: 36 | opam exec -- dune build --root . @install 37 | 38 | .PHONY: dev 39 | dev: ## Install development dependencies 40 | opam update 41 | opam install -y dune-release merlin ocamlformat utop ocaml-lsp-server 42 | opam install --deps-only --with-test --with-doc -y . 43 | 44 | .PHONY: switch 45 | switch: deps ## Create an opam switch and install development dependencies 46 | opam update 47 | # Ensuring that either a dev switch already exists or a new one is created 48 | [[ $(shell opam switch show) == $(shell pwd) ]] || \ 49 | opam switch create -y . 4.11.0 --deps-only --with-test --with-doc 50 | opam install -y dune-release merlin ocamlformat utop ocaml-lsp-server 51 | 52 | .PHONY: build 53 | build: ## Build the project, including non installable libraries and executables 54 | opam exec -- dune build --root . 55 | 56 | .PHONY: install 57 | install: all ## Install the packages on the system 58 | opam exec -- dune install --root . $(INSTALL_ARGS) opium 59 | 60 | .PHONY: uninstall 61 | uninstall: ## Uninstall the packages from the system 62 | opam exec -- dune uninstall --root . $(INSTALL_ARGS) opium 63 | 64 | .PHONY: test 65 | test: ## Run the unit tests 66 | opam exec -- dune runtest --root . 67 | 68 | .PHONY: clean 69 | clean: ## Clean build artifacts and other generated files 70 | opam exec -- dune clean --root . 71 | 72 | .PHONY: doc 73 | doc: ## Generate odoc documentation 74 | opam exec -- dune build --root . @doc 75 | 76 | .PHONY: servedoc 77 | servedoc: doc ## Open odoc documentation with default web browser 78 | $(BROWSER) _build/default/_doc/_html/index.html 79 | 80 | .PHONY: fmt 81 | fmt: ## Format the codebase with ocamlformat 82 | opam exec -- dune build --root . --auto-promote @fmt 83 | 84 | .PHONY: watch 85 | watch: ## Watch for the filesystem and rebuild on every change 86 | opam exec -- dune build --root . --watch 87 | 88 | .PHONY: utop 89 | utop: ## Run a REPL and link with the project's libraries 90 | opam exec -- dune utop --root . . -- -implicit-bindings 91 | 92 | .PHONY: release 93 | release: ## Release the latest version 94 | opam exec -- dune-release tag 95 | opam exec -- dune-release distrib -n opium 96 | opam exec -- dune-release publish distrib --verbose -n opium 97 | opam exec -- dune-release opam pkg -n opium 98 | opam exec -- dune-release opam submit -n opium 99 | 100 | .PHONY: opam-selection 101 | opam-selection: nix/opam-selection.nix 102 | nix/opam-selection.nix: default.nix 103 | nix-shell -A resolve $< 104 | -------------------------------------------------------------------------------- /README.cpp.md: -------------------------------------------------------------------------------- 1 | Opium 2 | ===== 3 | 4 | Since version 0.19.0, Opium uses httpaf. The last version that used Cohttp can be found at https://github.com/rgrinberg/opium/tree/0.18.0 5 | 6 | ## Executive Summary 7 | 8 | Sinatra like web toolkit for OCaml based on [httpaf](https://github.com/inhabitedtype/httpaf/) & [lwt](https://github.com/ocsigen/lwt) 9 | 10 | ## Design Goals 11 | 12 | * Opium should be very small and easily learnable. A programmer should 13 | be instantly productive when starting out. 14 | 15 | * Opium should be extensible using independently developed plugins. This is a 16 | _Rack_ inspired mechanism borrowed from Ruby. The middleware mechanism in 17 | Opium is called `Rock`. 18 | 19 | ## Installation 20 | 21 | ### Stable 22 | 23 | The latest stable version is available on opam 24 | 25 | ``` 26 | $ opam install opium 27 | ``` 28 | 29 | ### Master 30 | 31 | ``` 32 | $ opam pin add rock.~dev https://github.com/rgrinberg/opium.git 33 | $ opam pin add opium.~dev https://github.com/rgrinberg/opium.git 34 | ``` 35 | 36 | ## Documentation 37 | 38 | For the **API documentation**: 39 | 40 | - Read [the hosted documentation for the latest version][hosted-docs]. 41 | - Build and view the docs for version installed locally using [`odig`][odig]: 42 | `odig doc opium`. 43 | 44 | The following **tutorials** walk through various usecases of Opium: 45 | 46 | - [A Lightweight OCaml Webapp Tutorial](https://shonfeder.gitlab.io/ocaml_webapp/) 47 | covers a simple webapp generating dynamic HTML on the backend and 48 | interfacing with PostgreSQL. 49 | 50 | For **examples** of idiomatic usage, see the [./examples directory](./examples) 51 | and the simple examples below. 52 | 53 | [hosted-docs]: https://rgrinberg.github.io/opium/ 54 | [odig]: https://github.com/b0-system/odig 55 | 56 | ## Examples 57 | 58 | Assuming the necessary dependencies are installed, `$ dune build @example` will 59 | compile all examples. The binaries are located in `_build/default/example/`. 60 | 61 | You can execute these binaries directly, though in the examples below we use 62 | `dune exec` to run them. 63 | 64 | ### Hello World 65 | 66 | Here's a simple hello world example to get your feet wet: 67 | 68 | `$ cat hello_world.ml` 69 | 70 | ``` ocaml 71 | #include "example/hello_world/main.ml" 72 | ``` 73 | 74 | compile and run with: 75 | 76 | ```sh 77 | $ dune exec examples/hello_world.exe & 78 | ``` 79 | 80 | then call 81 | 82 | ```sh 83 | curl http://localhost:3000/person/john_doe/42 84 | ``` 85 | 86 | You should see the greeting 87 | 88 | ```json 89 | {"name":"john_doe","age":42} 90 | ``` 91 | 92 | ### Middleware 93 | 94 | The two fundamental building blocks of opium are: 95 | 96 | * Handlers: `Request.t -> Response.t Lwt.t` 97 | * Middleware: `Rock.Handler.t -> Rock.Handler.t` 98 | 99 | Almost all of opium's functionality is assembled through various 100 | middleware. For example: debugging, routing, serving static files, 101 | etc. Creating middleware is usually the most natural way to extend an 102 | opium app. 103 | 104 | Here's how you'd create a simple middleware turning away everyone's 105 | favourite browser. 106 | 107 | ``` ocaml 108 | #include "example/simple_middleware/main.ml" 109 | ``` 110 | 111 | Compile with: 112 | 113 | ```sh 114 | $ dune build example/simple_middleware/main.ml 115 | ``` 116 | 117 | Here we also use the ability of Opium to generate a cmdliner term to run your 118 | app. Run your executable with `-h` to see the options that are available to you. 119 | For example: 120 | 121 | ``` 122 | # run in debug mode on port 9000 123 | $ dune exec dune build example/simple_middleware/main.exe -- -p 9000 -d 124 | ``` 125 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Opium 2 | ===== 3 | 4 | Since version 0.19.0, Opium uses httpaf. The last version that used Cohttp can be found at https://github.com/rgrinberg/opium/tree/0.18.0 5 | 6 | ## Executive Summary 7 | 8 | Sinatra like web toolkit for OCaml based on [httpaf](https://github.com/inhabitedtype/httpaf/) & [lwt](https://github.com/ocsigen/lwt) 9 | 10 | ## Design Goals 11 | 12 | * Opium should be very small and easily learnable. A programmer should 13 | be instantly productive when starting out. 14 | 15 | * Opium should be extensible using independently developed plugins. This is a 16 | _Rack_ inspired mechanism borrowed from Ruby. The middleware mechanism in 17 | Opium is called `Rock`. 18 | 19 | ## Installation 20 | 21 | ### Stable 22 | 23 | The latest stable version is available on opam 24 | 25 | ``` 26 | $ opam install opium 27 | ``` 28 | 29 | ### Master 30 | 31 | ``` 32 | $ opam pin add rock.~dev https://github.com/rgrinberg/opium.git 33 | $ opam pin add opium.~dev https://github.com/rgrinberg/opium.git 34 | ``` 35 | 36 | ## Documentation 37 | 38 | For the **API documentation**: 39 | 40 | - Read [the hosted documentation for the latest version][hosted-docs]. 41 | - Build and view the docs for version installed locally using [`odig`][odig]: 42 | `odig doc opium`. 43 | 44 | The following **tutorials** walk through various usecases of Opium: 45 | 46 | - [A Lightweight OCaml Webapp Tutorial](https://shonfeder.gitlab.io/ocaml_webapp/) 47 | covers a simple webapp generating dynamic HTML on the backend and 48 | interfacing with PostgreSQL. 49 | 50 | For **examples** of idiomatic usage, see the [./example directory](./example) 51 | and the simple examples below. 52 | 53 | [hosted-docs]: https://rgrinberg.github.io/opium/ 54 | [odig]: https://github.com/b0-system/odig 55 | 56 | ## Examples 57 | 58 | Assuming the necessary dependencies are installed, `$ dune build @example` will 59 | compile all examples. The binaries are located in `_build/default/example/`. 60 | 61 | You can execute these binaries directly, though in the examples below we use 62 | `dune exec` to run them. 63 | 64 | ### Hello World 65 | 66 | Here's a simple hello world example to get your feet wet: 67 | 68 | `$ cat hello_world.ml` 69 | 70 | ``` ocaml 71 | open Opium 72 | 73 | module Person = struct 74 | type t = 75 | { name : string 76 | ; age : int 77 | } 78 | 79 | let yojson_of_t t = `Assoc [ "name", `String t.name; "age", `Int t.age ] 80 | 81 | let t_of_yojson yojson = 82 | match yojson with 83 | | `Assoc [ ("name", `String name); ("age", `Int age) ] -> { name; age } 84 | | _ -> failwith "invalid person json" 85 | ;; 86 | end 87 | 88 | let print_person_handler req = 89 | let name = Router.param req "name" in 90 | let age = Router.param req "age" |> int_of_string in 91 | let person = { Person.name; age } |> Person.yojson_of_t in 92 | Lwt.return (Response.of_json person) 93 | ;; 94 | 95 | let update_person_handler req = 96 | let open Lwt.Syntax in 97 | let+ json = Request.to_json_exn req in 98 | let person = Person.t_of_yojson json in 99 | Logs.info (fun m -> m "Received person: %s" person.Person.name); 100 | Response.of_json (`Assoc [ "message", `String "Person saved" ]) 101 | ;; 102 | 103 | let streaming_handler req = 104 | let length = Body.length req.Request.body in 105 | let content = Body.to_stream req.Request.body in 106 | let body = Lwt_stream.map String.uppercase_ascii content in 107 | Response.make ~body:(Body.of_stream ?length body) () |> Lwt.return 108 | ;; 109 | 110 | let print_param_handler req = 111 | Printf.sprintf "Hello, %s\n" (Router.param req "name") 112 | |> Response.of_plain_text 113 | |> Lwt.return 114 | ;; 115 | 116 | let _ = 117 | App.empty 118 | |> App.post "/hello/stream" streaming_handler 119 | |> App.get "/hello/:name" print_param_handler 120 | |> App.get "/person/:name/:age" print_person_handler 121 | |> App.patch "/person" update_person_handler 122 | |> App.run_command 123 | ;; 124 | ``` 125 | 126 | compile and run with: 127 | 128 | ```sh-session 129 | $ dune exec examples/hello_world.exe & 130 | ``` 131 | 132 | then make a request to be greeted with a JSON response 133 | 134 | ```sh-session 135 | $ curl http://localhost:3000/person/john_doe/42 136 | {"name":"john_doe","age":42} 137 | ``` 138 | 139 | ### Middleware 140 | 141 | The two fundamental building blocks of opium are: 142 | 143 | * Handlers: `Request.t -> Response.t Lwt.t` 144 | * Middleware: `Rock.Handler.t -> Rock.Handler.t` 145 | 146 | Almost all of opium's functionality is assembled through various 147 | middleware. For example: debugging, routing, serving static files, 148 | etc. Creating middleware is usually the most natural way to extend an 149 | opium app. 150 | 151 | Here's how you'd create a simple middleware turning away everyone's 152 | favourite browser. 153 | 154 | ``` ocaml 155 | open Opium 156 | 157 | module Reject_user_agent = struct 158 | let is_ua_msie = 159 | let re = Re.compile (Re.str "MSIE") in 160 | Re.execp re 161 | ;; 162 | 163 | let m = 164 | let filter handler req = 165 | match Request.header "user-agent" req with 166 | | Some ua when is_ua_msie ua -> 167 | Response.of_plain_text ~status:`Bad_request "Please upgrade your browser" 168 | |> Lwt.return 169 | | _ -> handler req 170 | in 171 | Rock.Middleware.create ~filter ~name:"Reject User-Agent" 172 | ;; 173 | end 174 | 175 | let index_handler _request = Response.of_plain_text "Hello World!" |> Lwt.return 176 | 177 | let _ = 178 | App.empty 179 | |> App.get "/" index_handler 180 | |> App.middleware Reject_user_agent.m 181 | |> App.cmd_name "Reject UA" 182 | |> App.run_command 183 | ;; 184 | ``` 185 | 186 | Compile with: 187 | 188 | ```sh 189 | $ dune build example/simple_middleware/main.ml 190 | ``` 191 | 192 | Here we also use the ability of Opium to generate a cmdliner term to run your 193 | app. Run your executable with `-h` to see the options that are available to you. 194 | For example: 195 | 196 | ```sh-session 197 | # run in debug mode on port 9000 198 | $ dune exec dune build example/simple_middleware/main.exe -- -p 9000 -d 199 | ``` 200 | -------------------------------------------------------------------------------- /benchmark/README.md: -------------------------------------------------------------------------------- 1 | # Opium Benchmark 2 | 3 | Benchmarking of Opium with `wrk2`. 4 | 5 | ## Install wrk 6 | 7 | We use wrk2 to generate the benchmark. 8 | 9 | If you're on macOS, you can install wrk2 with: 10 | 11 | ```sh 12 | brew tap jabley/homebrew-wrk2 13 | brew install --HEAD wrk2 14 | ``` 15 | 16 | ## Run the benchmarks 17 | 18 | To run a benchmark, simply execute the `run.sh` script: 19 | ```sh 20 | ./benchmark/run.sh 21 | ``` 22 | 23 | It will spawn the servers and kill them when the benchmarks are over. 24 | 25 | ## Results 26 | 27 | The results of the benchmarks can be found in `result/opium.log`. 28 | 29 | Here's a plot of the historgram with all of them. 30 | 31 | ![](./result/histogram.png) 32 | 33 | It has been generated with [hdrhistogram](http://hdrhistogram.github.io/HdrHistogram/plotFiles.html). 34 | -------------------------------------------------------------------------------- /benchmark/result/histogram.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rgrinberg/opium/73b16f0487497e02750c1123ead377a56be3be43/benchmark/result/histogram.png -------------------------------------------------------------------------------- /benchmark/result/httpaf.log: -------------------------------------------------------------------------------- 1 | Running 1m test @ http://localhost:3000/ 2 | 8 threads and 10000 connections 3 | Thread calibration: mean lat.: 4.688ms, rate sampling interval: 18ms 4 | Thread calibration: mean lat.: 4.576ms, rate sampling interval: 17ms 5 | Thread calibration: mean lat.: 4.412ms, rate sampling interval: 16ms 6 | Thread calibration: mean lat.: 3.616ms, rate sampling interval: 11ms 7 | Thread calibration: mean lat.: 4.312ms, rate sampling interval: 16ms 8 | Thread calibration: mean lat.: 3.558ms, rate sampling interval: 12ms 9 | Thread calibration: mean lat.: 3.651ms, rate sampling interval: 13ms 10 | Thread calibration: mean lat.: 4.426ms, rate sampling interval: 17ms 11 | Thread Stats Avg Stdev Max +/- Stdev 12 | Latency 2.69ms 1.15ms 8.65ms 72.78% 13 | Req/Sec 100.64 409.14 2.41k 94.24% 14 | Latency Distribution (HdrHistogram - Recorded Latency) 15 | 50.000% 2.59ms 16 | 75.000% 3.19ms 17 | 90.000% 4.17ms 18 | 99.000% 6.28ms 19 | 99.900% 8.00ms 20 | 99.990% 8.47ms 21 | 99.999% 8.65ms 22 | 100.000% 8.65ms 23 | 24 | Detailed Percentile spectrum: 25 | Value Percentile TotalCount 1/(1-Percentile) 26 | 27 | 0.205 0.000000 1 1.00 28 | 1.384 0.100000 3186 1.11 29 | 1.751 0.200000 6373 1.25 30 | 2.065 0.300000 9553 1.43 31 | 2.311 0.400000 12758 1.67 32 | 2.589 0.500000 15938 2.00 33 | 2.693 0.550000 17530 2.22 34 | 2.801 0.600000 19113 2.50 35 | 2.925 0.650000 20713 2.86 36 | 3.035 0.700000 22305 3.33 37 | 3.193 0.750000 23875 4.00 38 | 3.303 0.775000 24671 4.44 39 | 3.403 0.800000 25477 5.00 40 | 3.501 0.825000 26265 5.71 41 | 3.665 0.850000 27062 6.67 42 | 3.913 0.875000 27859 8.00 43 | 4.065 0.887500 28255 8.89 44 | 4.167 0.900000 28657 10.00 45 | 4.291 0.912500 29050 11.43 46 | 4.439 0.925000 29448 13.33 47 | 4.651 0.937500 29847 16.00 48 | 4.775 0.943750 30046 17.78 49 | 4.927 0.950000 30242 20.00 50 | 5.071 0.956250 30442 22.86 51 | 5.215 0.962500 30642 26.67 52 | 5.383 0.968750 30840 32.00 53 | 5.455 0.971875 30943 35.56 54 | 5.555 0.975000 31038 40.00 55 | 5.679 0.978125 31137 45.71 56 | 5.767 0.981250 31238 53.33 57 | 5.931 0.984375 31336 64.00 58 | 6.003 0.985938 31387 71.11 59 | 6.103 0.987500 31438 80.00 60 | 6.207 0.989062 31485 91.43 61 | 6.343 0.990625 31535 106.67 62 | 6.487 0.992188 31585 128.00 63 | 6.611 0.992969 31610 142.22 64 | 6.891 0.993750 31635 160.00 65 | 7.147 0.994531 31659 182.86 66 | 7.335 0.995313 31684 213.33 67 | 7.483 0.996094 31709 256.00 68 | 7.543 0.996484 31722 284.44 69 | 7.599 0.996875 31734 320.00 70 | 7.659 0.997266 31746 365.71 71 | 7.735 0.997656 31759 426.67 72 | 7.799 0.998047 31771 512.00 73 | 7.847 0.998242 31778 568.89 74 | 7.899 0.998437 31784 640.00 75 | 7.931 0.998633 31791 731.43 76 | 7.955 0.998828 31796 853.33 77 | 8.015 0.999023 31802 1024.00 78 | 8.071 0.999121 31806 1137.78 79 | 8.087 0.999219 31809 1280.00 80 | 8.115 0.999316 31812 1462.86 81 | 8.155 0.999414 31815 1706.67 82 | 8.187 0.999512 31818 2048.00 83 | 8.247 0.999561 31821 2275.56 84 | 8.247 0.999609 31821 2560.00 85 | 8.279 0.999658 31823 2925.71 86 | 8.295 0.999707 31825 3413.33 87 | 8.383 0.999756 31826 4096.00 88 | 8.415 0.999780 31827 4551.11 89 | 8.415 0.999805 31827 5120.00 90 | 8.447 0.999829 31828 5851.43 91 | 8.455 0.999854 31829 6826.67 92 | 8.471 0.999878 31831 8192.00 93 | 8.471 0.999890 31831 9102.22 94 | 8.471 0.999902 31831 10240.00 95 | 8.471 0.999915 31831 11702.86 96 | 8.471 0.999927 31831 13653.33 97 | 8.575 0.999939 31832 16384.00 98 | 8.575 0.999945 31832 18204.44 99 | 8.575 0.999951 31832 20480.00 100 | 8.575 0.999957 31832 23405.71 101 | 8.575 0.999963 31832 27306.67 102 | 8.655 0.999969 31833 32768.00 103 | 8.655 1.000000 31833 inf 104 | #[Mean = 2.687, StdDeviation = 1.147] 105 | #[Max = 8.648, Total count = 31833] 106 | #[Buckets = 27, SubBuckets = 2048] 107 | ---------------------------------------------------------- 108 | 43022 requests in 1.00m, 85.91MB read 109 | Socket errors: connect 9757, read 69, write 0, timeout 253682 110 | Requests/sec: 716.96 111 | Transfer/sec: 1.43MB 112 | -------------------------------------------------------------------------------- /benchmark/result/opium.log: -------------------------------------------------------------------------------- 1 | Running 1m test @ http://localhost:3000/ 2 | 8 threads and 10000 connections 3 | Thread calibration: mean lat.: 4.331ms, rate sampling interval: 17ms 4 | Thread calibration: mean lat.: 4.325ms, rate sampling interval: 17ms 5 | Thread calibration: mean lat.: 4.261ms, rate sampling interval: 17ms 6 | Thread calibration: mean lat.: 3.563ms, rate sampling interval: 13ms 7 | Thread calibration: mean lat.: 9223372036854776.000ms, rate sampling interval: 10ms 8 | Thread calibration: mean lat.: 9223372036854776.000ms, rate sampling interval: 10ms 9 | Thread calibration: mean lat.: 3.688ms, rate sampling interval: 13ms 10 | Thread calibration: mean lat.: 3.627ms, rate sampling interval: 12ms 11 | Thread Stats Avg Stdev Max +/- Stdev 12 | Latency 2.40ms 0.89ms 9.84ms 72.28% 13 | Req/Sec 88.68 455.47 3.56k 96.02% 14 | Latency Distribution (HdrHistogram - Recorded Latency) 15 | 50.000% 2.28ms 16 | 75.000% 2.87ms 17 | 90.000% 3.57ms 18 | 99.000% 4.86ms 19 | 99.900% 8.57ms 20 | 99.990% 9.51ms 21 | 99.999% 9.85ms 22 | 100.000% 9.85ms 23 | 24 | Detailed Percentile spectrum: 25 | Value Percentile TotalCount 1/(1-Percentile) 26 | 27 | 0.369 0.000000 1 1.00 28 | 1.406 0.100000 3185 1.11 29 | 1.671 0.200000 6377 1.25 30 | 1.891 0.300000 9553 1.43 31 | 2.089 0.400000 12748 1.67 32 | 2.283 0.500000 15942 2.00 33 | 2.373 0.550000 17525 2.22 34 | 2.491 0.600000 19124 2.50 35 | 2.601 0.650000 20708 2.86 36 | 2.739 0.700000 22290 3.33 37 | 2.865 0.750000 23899 4.00 38 | 2.943 0.775000 24682 4.44 39 | 3.019 0.800000 25495 5.00 40 | 3.129 0.825000 26282 5.71 41 | 3.243 0.850000 27065 6.67 42 | 3.405 0.875000 27861 8.00 43 | 3.499 0.887500 28253 8.89 44 | 3.573 0.900000 28652 10.00 45 | 3.663 0.912500 29057 11.43 46 | 3.797 0.925000 29448 13.33 47 | 3.905 0.937500 29846 16.00 48 | 3.969 0.943750 30049 17.78 49 | 4.057 0.950000 30244 20.00 50 | 4.143 0.956250 30443 22.86 51 | 4.223 0.962500 30647 26.67 52 | 4.339 0.968750 30843 32.00 53 | 4.391 0.971875 30939 35.56 54 | 4.435 0.975000 31044 40.00 55 | 4.483 0.978125 31141 45.71 56 | 4.563 0.981250 31237 53.33 57 | 4.643 0.984375 31338 64.00 58 | 4.691 0.985938 31390 71.11 59 | 4.727 0.987500 31441 80.00 60 | 4.787 0.989062 31486 91.43 61 | 4.883 0.990625 31535 106.67 62 | 4.955 0.992188 31586 128.00 63 | 5.015 0.992969 31610 142.22 64 | 5.103 0.993750 31637 160.00 65 | 5.219 0.994531 31659 182.86 66 | 5.531 0.995313 31684 213.33 67 | 5.647 0.996094 31709 256.00 68 | 5.675 0.996484 31724 284.44 69 | 5.687 0.996875 31734 320.00 70 | 5.731 0.997266 31746 365.71 71 | 6.095 0.997656 31759 426.67 72 | 6.899 0.998047 31771 512.00 73 | 7.103 0.998242 31778 568.89 74 | 7.291 0.998437 31784 640.00 75 | 7.435 0.998633 31790 731.43 76 | 7.943 0.998828 31796 853.33 77 | 8.583 0.999023 31802 1024.00 78 | 8.639 0.999121 31806 1137.78 79 | 8.663 0.999219 31809 1280.00 80 | 8.703 0.999316 31812 1462.86 81 | 8.775 0.999414 31815 1706.67 82 | 8.807 0.999512 31818 2048.00 83 | 8.951 0.999561 31820 2275.56 84 | 8.959 0.999609 31821 2560.00 85 | 9.023 0.999658 31823 2925.71 86 | 9.135 0.999707 31825 3413.33 87 | 9.263 0.999756 31826 4096.00 88 | 9.271 0.999780 31827 4551.11 89 | 9.271 0.999805 31827 5120.00 90 | 9.383 0.999829 31828 5851.43 91 | 9.391 0.999854 31829 6826.67 92 | 9.511 0.999878 31830 8192.00 93 | 9.511 0.999890 31830 9102.22 94 | 9.511 0.999902 31830 10240.00 95 | 9.527 0.999915 31831 11702.86 96 | 9.527 0.999927 31831 13653.33 97 | 9.799 0.999939 31832 16384.00 98 | 9.799 0.999945 31832 18204.44 99 | 9.799 0.999951 31832 20480.00 100 | 9.799 0.999957 31832 23405.71 101 | 9.799 0.999963 31832 27306.67 102 | 9.847 0.999969 31833 32768.00 103 | 9.847 1.000000 31833 inf 104 | #[Mean = 2.402, StdDeviation = 0.889] 105 | #[Max = 9.840, Total count = 31833] 106 | #[Buckets = 27, SubBuckets = 2048] 107 | ---------------------------------------------------------- 108 | 43019 requests in 1.00m, 3.94MB read 109 | Socket errors: connect 9757, read 0, write 0, timeout 256182 110 | Non-2xx or 3xx responses: 43019 111 | Requests/sec: 713.63 112 | Transfer/sec: 66.90KB 113 | -------------------------------------------------------------------------------- /benchmark/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | opam exec -- dune exec "benchmark/src/opium.exe" & 6 | pid=$! 7 | 8 | # Wait for the server to start 9 | sleep 1 10 | 11 | echo "Running benchmarks with opium.exe" 12 | 13 | wrk2 \ 14 | -t8 -c10000 -d60S \ 15 | --timeout 2000 \ 16 | -R 30000 --latency \ 17 | -H 'Connection: keep-alive' \ 18 | http://localhost:3000/ \ 19 | > "benchmark/result/opium.log" 2>&1 20 | 21 | kill $pid 22 | 23 | opam exec -- dune exec "benchmark/src/httpaf.exe" & 24 | pid=$! 25 | 26 | # Wait for the server to start 27 | sleep 1 28 | 29 | echo "Running benchmarks with httpaf.exe" 30 | 31 | wrk2 \ 32 | -t8 -c10000 -d60S \ 33 | --timeout 2000 \ 34 | -R 30000 --latency \ 35 | -H 'Connection: keep-alive' \ 36 | http://localhost:3000/ \ 37 | > "benchmark/result/httpaf.log" 2>&1 38 | 39 | kill $pid 40 | -------------------------------------------------------------------------------- /benchmark/src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name opium) 3 | (modules opium) 4 | (libraries opium)) 5 | 6 | (executable 7 | (name httpaf) 8 | (modules httpaf) 9 | (libraries httpaf-lwt-unix)) 10 | -------------------------------------------------------------------------------- /benchmark/src/httpaf.ml: -------------------------------------------------------------------------------- 1 | open Httpaf 2 | open Httpaf_lwt_unix 3 | 4 | let text = 5 | "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by \ 6 | her sister on the bank, and of having nothing to do: once or twice she had peeped \ 7 | into the book her sister was reading, but it had no pictures or conversations in it, \ 8 | thought Alice \ 9 | So she was considering in her own mind (as well as she could, for the hot day made \ 10 | her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would \ 11 | be worth the trouble of getting up and picking the daisies, when suddenly a White \ 12 | Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; \ 13 | nor did Alice think it so very much out of the way to hear the Rabbit say to itself, \ 14 | (when she thought it over afterwards, it \ 15 | occurred to her that she ought to have wondered at this, but at the time it all \ 16 | seemed quite natural); but when the Rabbit actually took a watch out of its \ 17 | waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, \ 18 | for it flashed across her mind that she had never before seen a rabbit with either a \ 19 | waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran \ 20 | across the field after it, and fortunately was just in time to see it pop down a \ 21 | large rabbit-hole under the hedge. In another moment down went Alice after it, never \ 22 | once considering how in the world she was to get out again. The rabbit-hole went \ 23 | straight on like a tunnel for some way, and then dipped suddenly down, so suddenly \ 24 | that Alice had not a moment to think about stopping herself before she found herself \ 25 | falling down a very deep well. Either the well was very deep, or she fell very \ 26 | slowly, for she had plenty of time as she went down to look about her and to wonder \ 27 | what was going to happen next. First, she tried to look down and make out what she \ 28 | was coming to, but it was too dark to see anything; then she looked at the sides of \ 29 | the well, and noticed that they were filled with cupboards......" 30 | ;; 31 | 32 | let benchmark = 33 | let headers = 34 | Headers.of_list [ "content-length", Int.to_string (String.length text) ] 35 | in 36 | let handler reqd = 37 | let { Request.target; _ } = Reqd.request reqd in 38 | let request_body = Reqd.request_body reqd in 39 | Body.close_reader request_body; 40 | match target with 41 | | "/" -> Reqd.respond_with_string reqd (Response.create ~headers `OK) text 42 | | _ -> Reqd.respond_with_string reqd (Response.create `Not_found) "Route not found" 43 | in 44 | handler 45 | ;; 46 | 47 | let error_handler ?request:_ error start_response = 48 | let response_body = start_response Headers.empty in 49 | (match error with 50 | | `Exn exn -> 51 | Body.write_string response_body (Printexc.to_string exn); 52 | Body.write_string response_body "\n" 53 | | #Status.standard as error -> 54 | Body.write_string response_body (Status.default_reason_phrase error)); 55 | Body.close_writer response_body 56 | ;; 57 | 58 | let () = 59 | let open Lwt.Infix in 60 | let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 3000)) in 61 | let request_handler _ = benchmark in 62 | let error_handler _ = error_handler in 63 | Lwt.async (fun () -> 64 | Lwt_io.establish_server_with_client_socket 65 | ~backlog:11_000 66 | listen_address 67 | (Server.create_connection_handler ~request_handler ~error_handler) 68 | >>= fun _server -> Lwt.return_unit); 69 | let forever, _ = Lwt.wait () in 70 | Lwt_main.run forever 71 | ;; 72 | -------------------------------------------------------------------------------- /benchmark/src/opium.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let text = 4 | "CHAPTER I. Down the Rabbit-Hole Alice was beginning to get very tired of sitting by \ 5 | her sister on the bank, and of having nothing to do: once or twice she had peeped \ 6 | into the book her sister was reading, but it had no pictures or conversations in it, \ 7 | thought Alice \ 8 | So she was considering in her own mind (as well as she could, for the hot day made \ 9 | her feel very sleepy and stupid), whether the pleasure of making a daisy-chain would \ 10 | be worth the trouble of getting up and picking the daisies, when suddenly a White \ 11 | Rabbit with pink eyes ran close by her. There was nothing so very remarkable in that; \ 12 | nor did Alice think it so very much out of the way to hear the Rabbit say to itself, \ 13 | (when she thought it over afterwards, it \ 14 | occurred to her that she ought to have wondered at this, but at the time it all \ 15 | seemed quite natural); but when the Rabbit actually took a watch out of its \ 16 | waistcoat-pocket, and looked at it, and then hurried on, Alice started to her feet, \ 17 | for it flashed across her mind that she had never before seen a rabbit with either a \ 18 | waistcoat-pocket, or a watch to take out of it, and burning with curiosity, she ran \ 19 | across the field after it, and fortunately was just in time to see it pop down a \ 20 | large rabbit-hole under the hedge. In another moment down went Alice after it, never \ 21 | once considering how in the world she was to get out again. The rabbit-hole went \ 22 | straight on like a tunnel for some way, and then dipped suddenly down, so suddenly \ 23 | that Alice had not a moment to think about stopping herself before she found herself \ 24 | falling down a very deep well. Either the well was very deep, or she fell very \ 25 | slowly, for she had plenty of time as she went down to look about her and to wonder \ 26 | what was going to happen next. First, she tried to look down and make out what she \ 27 | was coming to, but it was too dark to see anything; then she looked at the sides of \ 28 | the well, and noticed that they were filled with cupboards......" 29 | ;; 30 | 31 | let handler _req = Response.of_plain_text text |> Lwt.return 32 | let _ = App.empty |> App.get "/" handler |> App.run_command 33 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} 2 | , ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_13 3 | , opam2nix ? 4 | pkgs.callPackage ./nix/opam2nix.nix { 5 | inherit pkgs; 6 | ocamlPackagesOverride = ocamlPackages; 7 | } }: 8 | 9 | pkgs.callPackage ./nix { inherit ocamlPackages opam2nix; } 10 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (mode promote) 3 | (deps 4 | (:dep README.cpp.md) 5 | (source_tree example/)) 6 | (target README.md) 7 | (action 8 | (run cppo -n %{dep} -o %{target}))) 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name opium) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github rgrinberg/opium)) 9 | 10 | (authors "Rudi Grinberg" "Anurag Soni" "Thibaut Mattio") 11 | 12 | (maintainers "Rudi Grinberg ") 13 | 14 | (documentation https://rgrinberg.github.io/opium/) 15 | 16 | (license MIT) 17 | 18 | (package 19 | (name rock) 20 | (synopsis 21 | "Minimalist framework to build extensible HTTP servers and clients") 22 | (description 23 | "Rock is a Unix indpendent API to build extensible HTTP servers and clients. It provides building blocks such as middlewares and handlers (a.k.a controllers).") 24 | (depends 25 | (ocaml 26 | (>= 4.08)) 27 | (lwt 28 | (>= 5.3.0)) 29 | bigstringaf 30 | hmap 31 | httpaf 32 | lwt 33 | sexplib0 34 | (odoc :with-doc))) 35 | 36 | (package 37 | (name opium) 38 | (synopsis "OCaml web framework") 39 | (description 40 | "Opium is a web framework for OCaml that provides everything you need to build safe, fast and extensible web applications.") 41 | (depends 42 | (ocaml 43 | (>= 4.08)) 44 | (rock 45 | (= :version)) 46 | (lwt 47 | (>= 5.3.0)) 48 | httpaf-lwt-unix 49 | logs 50 | fmt 51 | mtime 52 | cmdliner 53 | ptime 54 | magic-mime 55 | yojson 56 | tyxml 57 | digestif 58 | (base64 59 | (>= 3.0.0)) 60 | astring 61 | re 62 | uri 63 | multipart-form-data 64 | (result 65 | (>= 1.5)) 66 | (odoc :with-doc) 67 | (alcotest :with-test) 68 | (alcotest-lwt :with-test))) 69 | 70 | (package 71 | (name opium-testing) 72 | (synopsis "Testing library for Opium") 73 | (description 74 | "A library that provides helpers to easily test your Opium applications.") 75 | (depends 76 | (ocaml 77 | (>= 4.08)) 78 | (opium 79 | (= :version)) 80 | alcotest 81 | alcotest-lwt 82 | (odoc :with-doc))) 83 | 84 | (package 85 | (name opium-graphql) 86 | (synopsis "Run GraphQL servers with Opium") 87 | (description 88 | "This package allows you to execute Opium requests against GraphQL schemas built with `graphql`.") 89 | (depends 90 | (ocaml 91 | (>= 4.08)) 92 | (opium 93 | (= :version)) 94 | (lwt 95 | (>= 5.3.0)) 96 | graphql 97 | graphql-lwt 98 | (crunch :build) 99 | (alcotest :with-test) 100 | (alcotest-lwt :with-test))) 101 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (context 4 | (opam 5 | (switch 4.08.1))) 6 | 7 | (context 8 | (opam 9 | (switch 4.09.1))) 10 | 11 | (context 12 | (opam 13 | (switch 4.10.1))) 14 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # Examples 2 | 3 | This directory contains small, self-contained, examples of Opium applications. 4 | 5 | These examples showcase specific features of Opium, they do not demonstrate how to build a full-fledged web servers. 6 | 7 | - [`hello_world`](./hello_world): Demonstration of simple Opium application 8 | - [`exit_hook`](./exit_hook): How to clean up an and exit an Opium app 9 | - [`file_upload`](./file_upload): How to upload a file with a multipart form 10 | - [`html_response`](./html_response): How to implement HTML handlers 11 | - [`json_response`](./json_response): How to implement JSON handlers 12 | - [`json_request`](./json_request): How to read and decode JSON requests 13 | - [`rock_server`](./rock_server): How to implement an HTTP server with `Rock` 14 | - [`simple_middleware`](./simple_middleware): How to implement a simple middleware 15 | - [`static_serve`](./static_serve): How to serve static content 16 | - [`user_auth`](./user_auth): How to implement a basic user authentication system 17 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (alias 2 | (name example) 3 | (deps hello_world/main.exe exit_hook/main.exe file_upload/main.exe 4 | file_upload/simple.exe html_response/main.exe json_request/main.exe 5 | rock_server/main.exe simple_middleware/main.exe static_serve/main.exe 6 | user_auth/main.exe)) 7 | -------------------------------------------------------------------------------- /example/exit_hook/README.md: -------------------------------------------------------------------------------- 1 | # Exit Hook 2 | 3 | ``` 4 | dune exec example/exit_hook/main.exe 5 | ``` 6 | 7 | This example demonstrate how to execute arbitrary code after the opium app exists. 8 | 9 | All it does is force the application to exit after 2 seconds, and print "Bye!" once that's done. 10 | -------------------------------------------------------------------------------- /example/exit_hook/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/exit_hook/main.ml: -------------------------------------------------------------------------------- 1 | (* How to clean up and exit an opium app *) 2 | 3 | open Opium 4 | 5 | let hello_handler _ = Lwt.return @@ Response.of_plain_text "Hello World\n" 6 | 7 | let () = 8 | let app = App.empty |> App.get "/" hello_handler |> App.run_command' in 9 | match app with 10 | | `Ok app -> 11 | Lwt_main.at_exit (fun () -> Lwt.return (print_endline "Bye!")); 12 | let s = Lwt.join [ app; Lwt_unix.sleep 2.0 |> Lwt.map (fun _ -> Lwt.cancel app) ] in 13 | ignore (Lwt_main.run s) 14 | | `Error -> exit 1 15 | | `Not_running -> exit 0 16 | ;; 17 | -------------------------------------------------------------------------------- /example/file_upload/README.md: -------------------------------------------------------------------------------- 1 | # File Upload Example 2 | 3 | ``` 4 | dune exec example/file_upload/main.exe 5 | ``` 6 | 7 | This is an example of a simple file upload. 8 | 9 | The server offers two endpoints: 10 | 11 | - `/` to serve an HTML page with a form and an upload button 12 | - `/upload` that receives `multipart/form-data` `POST` requests and writes the content of uploaded files on the disk. 13 | 14 | You'll see that the `layout` and `index_view` functions are quite verbose. That's because we're using TailwindCSS and AlpineJS to create a nice UX, but that's got nothing to do with how file upload works. If you'd prefer to have a bare-bone file upload, check out the `simple.ml` file! 15 | 16 | The implementation of the `upload_handler` function is borrowed from [ReWeb](https://github.com/yawaramin/re-web/blob/main/ReWeb/Filter.ml#L237). 17 | -------------------------------------------------------------------------------- /example/file_upload/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main simple) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/file_upload/simple.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let layout ~title:title_ children = 4 | let open Tyxml.Html in 5 | html ~a:[ a_lang "en" ] (head (title (txt title_)) []) (body children) 6 | ;; 7 | 8 | let index_view = 9 | let open Tyxml.Html in 10 | layout 11 | ~title:"Opium file upload" 12 | [ form 13 | ~a:[ a_action "/upload"; a_method `Post; a_enctype "multipart/form-data" ] 14 | [ input ~a:[ a_input_type `File; a_name "file" ] () 15 | ; button ~a:[ a_button_type `Submit ] [ txt "Submit" ] 16 | ] 17 | ] 18 | ;; 19 | 20 | let index_handler _request = Lwt.return @@ Response.of_html index_view 21 | 22 | let upload_handler request = 23 | let open Lwt.Syntax in 24 | let files = Hashtbl.create ~random:true 5 in 25 | let callback ~name:_ ~filename string = 26 | let filename = Filename.basename filename in 27 | let write file = 28 | string |> String.length |> Lwt_unix.write_string file string 0 |> Lwt.map ignore 29 | in 30 | match Hashtbl.find_opt files filename with 31 | | Some file -> write file 32 | | None -> 33 | let* file = 34 | Lwt_unix.openfile filename Unix.[ O_CREAT; O_TRUNC; O_WRONLY; O_NONBLOCK ] 0o600 35 | in 36 | Hashtbl.add files filename file; 37 | write file 38 | in 39 | let* _ = Request.to_multipart_form_data_exn ~callback request in 40 | let close _ file prev = 41 | let* () = prev in 42 | Lwt_unix.close file 43 | in 44 | let* () = Hashtbl.fold close files Lwt.return_unit in 45 | Lwt.return @@ Response.of_plain_text "File uploaded successfully!" 46 | ;; 47 | 48 | let _ = 49 | App.empty 50 | |> App.get "/" index_handler 51 | |> App.post "/upload" upload_handler 52 | |> App.run_command 53 | ;; 54 | -------------------------------------------------------------------------------- /example/graphql/README.md: -------------------------------------------------------------------------------- 1 | # GraphQL 2 | 3 | ``` 4 | dune exec example/graphql/main.exe 5 | ``` 6 | 7 | This example implements a simple GraphQL API with Opium. It uses `opium-graphql` to interface with `ocaml-graphql-server`. 8 | 9 | The example provides two endpoints: 10 | 11 | - `/` that serves the actual GraphQL API 12 | - `/graphiql` that serves the GraphiQL tool 13 | 14 | To test the API, you can go on the GraphiQL tool and run the following query: 15 | 16 | ```graphql 17 | query { 18 | users { 19 | name 20 | } 21 | } 22 | ``` 23 | -------------------------------------------------------------------------------- /example/graphql/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium opium-graphql)) 4 | -------------------------------------------------------------------------------- /example/graphql/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | module Schema = struct 4 | open Graphql_lwt 5 | 6 | type context = unit 7 | 8 | type role = 9 | | User 10 | | Admin 11 | 12 | type user = 13 | { id : int 14 | ; name : string 15 | ; role : role 16 | } 17 | 18 | let users = 19 | [ { id = 1; name = "Alice"; role = Admin }; { id = 2; name = "Bob"; role = User } ] 20 | ;; 21 | 22 | let role : (context, role option) Graphql_lwt.Schema.typ = 23 | Schema.( 24 | enum 25 | "role" 26 | ~doc:"The role of a user" 27 | ~values:[ enum_value "USER" ~value:User; enum_value "ADMIN" ~value:Admin ]) 28 | ;; 29 | 30 | let user : (context, user option) Graphql_lwt.Schema.typ = 31 | Schema.( 32 | obj 33 | "user" 34 | ~doc:"A user in the system" 35 | ~fields: 36 | [ field 37 | "id" 38 | ~doc:"Unique user identifier" 39 | ~typ:(non_null int) 40 | ~args:Arg.[] 41 | ~resolve:(fun _info p -> p.id) 42 | ; field 43 | "name" 44 | ~typ:(non_null string) 45 | ~args:Arg.[] 46 | ~resolve:(fun _info p -> p.name) 47 | ; field 48 | "role" 49 | ~typ:(non_null role) 50 | ~args:Arg.[] 51 | ~resolve:(fun _info p -> p.role) 52 | ]) 53 | ;; 54 | 55 | let schema = 56 | Graphql_lwt.Schema.( 57 | schema 58 | [ field 59 | "users" 60 | ~typ:(non_null (list (non_null user))) 61 | ~args:Arg.[] 62 | ~resolve:(fun _info () -> users) 63 | ]) 64 | ;; 65 | end 66 | 67 | let graphql = 68 | let handler = Opium_graphql.make_handler ~make_context:(fun _req -> ()) Schema.schema in 69 | Opium.App.all "/" handler 70 | ;; 71 | 72 | let graphiql = 73 | let handler = Opium_graphql.make_graphiql_handler ~graphql_endpoint:"/" in 74 | Opium.App.get "/graphiql" handler 75 | ;; 76 | 77 | let _ = 78 | Logs.set_reporter (Logs_fmt.reporter ()); 79 | Logs.set_level (Some Logs.Debug); 80 | App.empty |> graphql |> graphiql |> App.run_command 81 | ;; 82 | -------------------------------------------------------------------------------- /example/hello_world/README.md: -------------------------------------------------------------------------------- 1 | # Hello World 2 | 3 | ``` 4 | dune exec example/hello_world/main.exe 5 | ``` 6 | 7 | This example showcases common Opium features: 8 | 9 | - Routing and router parameters 10 | - Reading and writing JSON 11 | - Streaming a response 12 | -------------------------------------------------------------------------------- /example/hello_world/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/hello_world/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | module Person = struct 4 | type t = 5 | { name : string 6 | ; age : int 7 | } 8 | 9 | let yojson_of_t t = `Assoc [ "name", `String t.name; "age", `Int t.age ] 10 | 11 | let t_of_yojson yojson = 12 | match yojson with 13 | | `Assoc [ ("name", `String name); ("age", `Int age) ] -> { name; age } 14 | | _ -> failwith "invalid person json" 15 | ;; 16 | end 17 | 18 | let print_person_handler req = 19 | let name = Router.param req "name" in 20 | let age = Router.param req "age" |> int_of_string in 21 | let person = { Person.name; age } |> Person.yojson_of_t in 22 | Lwt.return (Response.of_json person) 23 | ;; 24 | 25 | let update_person_handler req = 26 | let open Lwt.Syntax in 27 | let+ json = Request.to_json_exn req in 28 | let person = Person.t_of_yojson json in 29 | Logs.info (fun m -> m "Received person: %s" person.Person.name); 30 | Response.of_json (`Assoc [ "message", `String "Person saved" ]) 31 | ;; 32 | 33 | let streaming_handler req = 34 | let length = Body.length req.Request.body in 35 | let content = Body.to_stream req.Request.body in 36 | let body = Lwt_stream.map String.uppercase_ascii content in 37 | Response.make ~body:(Body.of_stream ?length body) () |> Lwt.return 38 | ;; 39 | 40 | let print_param_handler req = 41 | Printf.sprintf "Hello, %s\n" (Router.param req "name") 42 | |> Response.of_plain_text 43 | |> Lwt.return 44 | ;; 45 | 46 | let _ = 47 | App.empty 48 | |> App.post "/hello/stream" streaming_handler 49 | |> App.get "/hello/:name" print_param_handler 50 | |> App.get "/person/:name/:age" print_person_handler 51 | |> App.patch "/person" update_person_handler 52 | |> App.run_command 53 | ;; 54 | -------------------------------------------------------------------------------- /example/html_response/README.md: -------------------------------------------------------------------------------- 1 | # HTML Response 2 | 3 | ``` 4 | dune exec example/html_response/main.exe 5 | ``` 6 | 7 | This example shows how to serve HTML content. 8 | 9 | The `View` module contains `Tyxml` code with the following functions: 10 | 11 | - `layout ~title body` 12 | Build an HTML document with the title `title` and the body `body` 13 | 14 | - `check_icon` 15 | SVG element for a check icon 16 | 17 | - `index` 18 | HTML document with the content of our page 19 | -------------------------------------------------------------------------------- /example/html_response/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/html_response/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let index_handler _request = View.index |> Response.of_html |> Lwt.return 4 | let _ = App.empty |> App.get "/" index_handler |> App.run_command 5 | -------------------------------------------------------------------------------- /example/html_response/view.ml: -------------------------------------------------------------------------------- 1 | let layout ~title:title_ body_ = 2 | let open Tyxml.Html in 3 | html 4 | ~a:[ a_lang "en" ] 5 | (head 6 | (title (txt title_)) 7 | [ meta ~a:[ a_charset "utf-8" ] () 8 | ; meta ~a:[ a_name "viewport"; a_content "width=device-width, initial-scale=1" ] () 9 | ; meta ~a:[ a_name "theme-color"; a_content "#ffffff" ] () 10 | ; link 11 | ~rel:[ `Stylesheet ] 12 | ~href:"https://unpkg.com/tailwindcss@^1.8/dist/tailwind.min.css" 13 | () 14 | ]) 15 | (body body_) 16 | ;; 17 | 18 | let check_icon = 19 | let open Tyxml.Html in 20 | let a_svg_custom x y = Tyxml.Xml.string_attrib x y |> Tyxml.Svg.to_attrib in 21 | svg 22 | ~a: 23 | [ Tyxml.Svg.a_class [ "flex-shrink-0 h-5 w-5 text-teal-500" ] 24 | ; Tyxml.Svg.a_viewBox (0., 0., 20., 20.) 25 | ; Tyxml.Svg.a_fill `CurrentColor 26 | ] 27 | [ Tyxml.Svg.path 28 | ~a: 29 | [ a_svg_custom "fill-rule" "evenodd" 30 | ; Tyxml.Svg.a_d 31 | "M10 18a8 8 0 100-16 8 8 0 000 16zm3.707-9.293a1 1 0 00-1.414-1.414L9 \ 32 | 10.586 7.707 9.293a1 1 0 00-1.414 1.414l2 2a1 1 0 001.414 0l4-4z" 33 | ; a_svg_custom "clip-rule" "evenodd" 34 | ] 35 | [] 36 | ] 37 | ;; 38 | 39 | let index = 40 | let open Tyxml.Html in 41 | layout 42 | ~title:"Opium Example" 43 | [ div 44 | ~a: 45 | [ a_class 46 | [ "min-h-screen bg-gray-100 py-6 flex flex-col justify-center sm:py-12" ] 47 | ] 48 | [ div 49 | ~a:[ a_class [ "relative py-3 sm:max-w-xl sm:mx-auto" ] ] 50 | [ div 51 | ~a: 52 | [ a_class 53 | [ "relative px-4 py-10 bg-white shadow-lg sm:rounded-lg sm:p-20" ] 54 | ] 55 | [ div 56 | ~a:[ a_class [ "max-w-md mx-auto" ] ] 57 | [ div 58 | [ p 59 | ~a: 60 | [ a_class 61 | [ "mt-1 text-3xl leading-10 font-extrabold \ 62 | text-gray-900 sm:text-4xl sm:leading-none \ 63 | sm:tracking-tight lg:text-5xl" 64 | ] 65 | ] 66 | [ txt "Opium" ] 67 | ] 68 | ; div 69 | ~a:[ a_class [ "divide-y divide-gray-200" ] ] 70 | [ div 71 | ~a: 72 | [ a_class 73 | [ "py-8 text-base leading-6 space-y-4 text-gray-700 \ 74 | sm:text-lg sm:leading-7" 75 | ] 76 | ] 77 | [ p [ txt "Web Framework for OCaml" ] 78 | ; ul 79 | ~a:[ a_class [ "list-disc space-y-2" ] ] 80 | [ li 81 | ~a:[ a_class [ "flex items-start" ] ] 82 | [ span 83 | ~a:[ a_class [ "h-6 flex items-center sm:h-7" ] ] 84 | [ check_icon ] 85 | ; p 86 | ~a:[ a_class [ "ml-2" ] ] 87 | [ txt "Safe as in static typing" ] 88 | ] 89 | ; li 90 | ~a:[ a_class [ "flex items-start" ] ] 91 | [ span 92 | ~a:[ a_class [ "h-6 flex items-center sm:h-7" ] ] 93 | [ check_icon ] 94 | ; p 95 | ~a:[ a_class [ "ml-2" ] ] 96 | [ txt "Fast... " 97 | ; span 98 | ~a:[ a_class [ "font-bold text-gray-900" ] ] 99 | [ txt "really" ] 100 | ; txt " fast!" 101 | ] 102 | ] 103 | ; li 104 | ~a:[ a_class [ "flex items-start" ] ] 105 | [ span 106 | ~a:[ a_class [ "h-6 flex items-center sm:h-7" ] ] 107 | [ check_icon ] 108 | ; p 109 | ~a:[ a_class [ "ml-2" ] ] 110 | [ txt "Dozens of middlewares ready to use" ] 111 | ] 112 | ] 113 | ] 114 | ] 115 | ] 116 | ] 117 | ] 118 | ] 119 | ] 120 | ;; 121 | -------------------------------------------------------------------------------- /example/json_request/README.md: -------------------------------------------------------------------------------- 1 | # JSON Request 2 | 3 | ``` 4 | dune exec example/json_request/main.exe 5 | ``` 6 | 7 | This example shows how to read a JSON object from a request. 8 | 9 | The handler simply returns the string "Received response" if the body could be decoded. 10 | -------------------------------------------------------------------------------- /example/json_request/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/json_request/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let print_json req = 4 | req 5 | |> Request.to_json_exn 6 | |> fun _json -> Lwt.return (Response.make ~body:(Body.of_string "Received response") ()) 7 | ;; 8 | 9 | let _ = App.empty |> App.post "/" print_json |> App.run_command 10 | -------------------------------------------------------------------------------- /example/json_response/README.md: -------------------------------------------------------------------------------- 1 | # JSON Response Example 2 | 3 | ``` 4 | dune exec example/json_response/main.exe 5 | ``` 6 | 7 | This is an example of a JSON response. 8 | 9 | The server offers an endpoint `/` that serves a single JSON object. 10 | The JSON object is internally represented using `Yojson.Safe.t`, 11 | and populated with values from the `Sys` module. 12 | The function `Response.of_json` is used to serialize the JSON object and sets the correct content-type. 13 | 14 | Read more about [yojson](https://github.com/ocaml-community/yojson) at their homepage. 15 | -------------------------------------------------------------------------------- /example/json_response/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/json_response/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let sys_json _req = 4 | let json : Yojson.Safe.t = 5 | `Assoc [ "os-type", `String Sys.os_type; "ocaml-version", `String Sys.ocaml_version ] 6 | in 7 | Response.of_json json |> Lwt.return 8 | ;; 9 | 10 | let _ = App.empty |> App.get "/" sys_json |> App.run_command 11 | -------------------------------------------------------------------------------- /example/rock_server/README.md: -------------------------------------------------------------------------------- 1 | # Rock Server Example 2 | 3 | ``` 4 | dune exec example/rock_server/main.exe 5 | ``` 6 | 7 | This example shows how to setup a simple web server with only `rock`. 8 | -------------------------------------------------------------------------------- /example/rock_server/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries rock httpaf-lwt-unix)) 4 | -------------------------------------------------------------------------------- /example/rock_server/main.ml: -------------------------------------------------------------------------------- 1 | open Rock 2 | open Lwt.Syntax 3 | 4 | let index_handler _req = 5 | let headers = Httpaf.Headers.of_list [ "Content-Type", "text/plain" ] in 6 | let body = Body.of_string "Hello World!\n" in 7 | Lwt.return @@ Response.make ~headers ~body () 8 | ;; 9 | 10 | let sum_handler ~a ~b _req = 11 | let headers = Httpaf.Headers.of_list [ "Content-Type", "text/plain" ] in 12 | let body = Body.of_string (Printf.sprintf "Sum of %d and %d = %d\n" a b (a + b)) in 13 | Lwt.return @@ Response.make ~headers ~body () 14 | ;; 15 | 16 | module Router = struct 17 | let m = 18 | let filter handler req = 19 | let parts = 20 | req.Request.target 21 | |> String.split_on_char '/' 22 | |> List.filter (fun x -> not (String.equal x "")) 23 | in 24 | match parts with 25 | | [] -> index_handler req 26 | | [ "sum"; a; b ] -> sum_handler ~a:(int_of_string a) ~b:(int_of_string b) req 27 | | _ -> handler req 28 | in 29 | Middleware.create ~filter ~name:"" 30 | ;; 31 | end 32 | 33 | let app = 34 | Rock.App.create 35 | ~middlewares:[ Router.m ] 36 | ~handler:(fun _ -> 37 | let body = Body.of_string "No route found\n" in 38 | Lwt.return (Response.make ~status:`Not_found ~body ())) 39 | () 40 | ;; 41 | 42 | let sockaddr_to_string = function 43 | | Unix.ADDR_UNIX x -> x 44 | | ADDR_INET (inet_addr, port) -> 45 | Printf.sprintf "%s:%d" (Unix.string_of_inet_addr inet_addr) port 46 | ;; 47 | 48 | let run () = 49 | let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in 50 | let connection_handler addr fd = 51 | Httpaf_lwt_unix.Server.create_connection_handler 52 | ~request_handler:(fun addr -> 53 | Rock.Server_connection.to_httpaf_request_handler (sockaddr_to_string addr) app) 54 | ~error_handler:(fun addr -> 55 | Rock.Server_connection.( 56 | to_httpaf_error_handler Server_connection.default_error_handler) 57 | (sockaddr_to_string addr)) 58 | addr 59 | fd 60 | in 61 | Lwt.async (fun () -> 62 | let* _ = 63 | Lwt_io.establish_server_with_client_socket listen_address connection_handler 64 | in 65 | Lwt.return_unit); 66 | let forever, _ = Lwt.wait () in 67 | Lwt_main.run forever 68 | ;; 69 | 70 | let () = run () 71 | -------------------------------------------------------------------------------- /example/simple_middleware/README.md: -------------------------------------------------------------------------------- 1 | # Simple Middleware 2 | 3 | ``` 4 | dune exec example/simple_middleware/main.exe 5 | ``` 6 | 7 | This example shows how to implement a simple middleware. It implements an `Reject UA` middleware that rejects request if the User-Agent contains `"MSIE"`. 8 | -------------------------------------------------------------------------------- /example/simple_middleware/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/simple_middleware/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | module Reject_user_agent = struct 4 | let is_ua_msie = 5 | let re = Re.compile (Re.str "MSIE") in 6 | Re.execp re 7 | ;; 8 | 9 | let m = 10 | let filter handler req = 11 | match Request.header "user-agent" req with 12 | | Some ua when is_ua_msie ua -> 13 | Response.of_plain_text ~status:`Bad_request "Please upgrade your browser" 14 | |> Lwt.return 15 | | _ -> handler req 16 | in 17 | Rock.Middleware.create ~filter ~name:"Reject User-Agent" 18 | ;; 19 | end 20 | 21 | let index_handler _request = Response.of_plain_text "Hello World!" |> Lwt.return 22 | 23 | let _ = 24 | App.empty 25 | |> App.get "/" index_handler 26 | |> App.middleware Reject_user_agent.m 27 | |> App.cmd_name "Reject UA" 28 | |> App.run_command 29 | ;; 30 | -------------------------------------------------------------------------------- /example/static_serve/README.md: -------------------------------------------------------------------------------- 1 | # Static File Serving 2 | 3 | ``` 4 | dune exec example/static_serve/main.exe 5 | ``` 6 | 7 | Try it! You can open these URLs in your browser: 8 | 9 | - http://localhost:3000/favicon.ico 10 | - http://localhost:3000/robots.txt 11 | -------------------------------------------------------------------------------- /example/static_serve/asset/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rgrinberg/opium/73b16f0487497e02750c1123ead377a56be3be43/example/static_serve/asset/favicon.ico -------------------------------------------------------------------------------- /example/static_serve/asset/robots.txt: -------------------------------------------------------------------------------- 1 | # https://www.robotstxt.org/robotstxt.html 2 | User-agent: * -------------------------------------------------------------------------------- /example/static_serve/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium logs.fmt)) 4 | -------------------------------------------------------------------------------- /example/static_serve/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let () = 4 | let static = 5 | Middleware.static_unix ~local_path:"./example/static_serve/asset/" ~uri_prefix:"/" () 6 | in 7 | App.empty |> App.middleware static |> App.run_command 8 | ;; 9 | -------------------------------------------------------------------------------- /example/user_auth/README.md: -------------------------------------------------------------------------------- 1 | # User Auth 2 | 3 | ``` 4 | dune exec example/user_auth/main.exe 5 | ``` 6 | 7 | This example implements a very simple authentication system using `Basic` authentication. 8 | 9 | The middleware stores the authenticated user in the request's context, which can be retrieved in the handlers. 10 | 11 | The username and password for the authentication are `admin` and `admin`. 12 | 13 | You can test that you are authorized to access the `/` endpoint with the correct `Authorization` header: 14 | ```sh 15 | curl http://localhost:3000/ -X GET --user admin:admin 16 | ``` 17 | 18 | And that you are not allowed to access it when you don't provide the a valid `Authorization` header: 19 | ```sh 20 | curl http://localhost:3000/ -X GET 21 | ``` 22 | -------------------------------------------------------------------------------- /example/user_auth/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries opium)) 4 | -------------------------------------------------------------------------------- /example/user_auth/main.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | module User = struct 4 | type t = { username : string } 5 | 6 | let t_of_sexp sexp = 7 | let open Sexplib0.Sexp in 8 | match sexp with 9 | | List [ Atom "username"; Atom username ] -> { username } 10 | | _ -> failwith "invalid user sexp" 11 | ;; 12 | 13 | let sexp_of_t t = 14 | let open Sexplib0.Sexp in 15 | List [ Atom "username"; Atom t.username ] 16 | ;; 17 | end 18 | 19 | module Env_user = struct 20 | type t = User.t 21 | 22 | let key : t Opium.Context.key = Opium.Context.Key.create ("user", User.sexp_of_t) 23 | end 24 | 25 | let admin_handler req = 26 | let user = Opium.Context.find_exn Env_user.key req.Request.env in 27 | Response.of_plain_text (Printf.sprintf "Welcome back, %s!\n" user.username) 28 | |> Lwt.return 29 | ;; 30 | 31 | let unauthorized_handler _req = 32 | Response.of_plain_text ~status:`Unauthorized "Unauthorized!\n" |> Lwt.return 33 | ;; 34 | 35 | let auth_callback ~username ~password = 36 | match username, password with 37 | | "admin", "admin" -> Lwt.return_some User.{ username } 38 | | _ -> Lwt.return_none 39 | ;; 40 | 41 | let auth_middleware = 42 | Middleware.basic_auth 43 | ~key:Env_user.key 44 | ~auth_callback 45 | ~realm:"my_realm" 46 | ~unauthorized_handler 47 | () 48 | ;; 49 | 50 | let _ = 51 | App.empty 52 | |> App.middleware auth_middleware 53 | |> App.get "/" admin_handler 54 | |> App.run_command 55 | ;; 56 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { pkgs, lib, stdenv, ocamlPackages, opam2nix }: 2 | let 3 | inherit (lib) strings; 4 | args = { 5 | inherit (ocamlPackages) ocaml; 6 | selection = ./opam-selection.nix; 7 | src = 8 | let ignores = pkgs.lib.strings.fileContents ../.gitignore; 9 | in pkgs.nix-gitignore.gitignoreSourcePure ignores ../.; 10 | }; 11 | opam-selection = opam2nix.build args; 12 | localPackages = 13 | let contents = builtins.attrNames (builtins.readDir ../.); 14 | in builtins.filter (strings.hasSuffix ".opam") contents; 15 | resolve = opam2nix.resolve args (localPackages); 16 | 17 | in (builtins.listToAttrs (builtins.map (fname: 18 | let packageName = strings.removeSuffix ".opam" fname; 19 | in { 20 | name = packageName; 21 | value = builtins.getAttr packageName opam-selection; 22 | }) localPackages)) // { 23 | inherit resolve opam-selection; 24 | } 25 | -------------------------------------------------------------------------------- /nix/opam2nix.nix: -------------------------------------------------------------------------------- 1 | { source ? builtins.fetchTarball "https://github.com/timbertson/opam2nix/archive/v1.tar.gz" 2 | , pkgs 3 | , ocamlPackagesOverride }: 4 | import source { inherit pkgs ocamlPackagesOverride; } 5 | -------------------------------------------------------------------------------- /opium-graphql.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Run GraphQL servers with Opium" 4 | description: 5 | "This package allows you to execute Opium requests against GraphQL schemas built with `graphql`." 6 | maintainer: ["Rudi Grinberg "] 7 | authors: ["Rudi Grinberg" "Anurag Soni" "Thibaut Mattio"] 8 | license: "MIT" 9 | homepage: "https://github.com/rgrinberg/opium" 10 | doc: "https://rgrinberg.github.io/opium/" 11 | bug-reports: "https://github.com/rgrinberg/opium/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "ocaml" {>= "4.08"} 15 | "opium" {= version} 16 | "lwt" {>= "5.3.0"} 17 | "graphql" 18 | "graphql-lwt" 19 | "crunch" {build} 20 | "alcotest" {with-test} 21 | "alcotest-lwt" {with-test} 22 | ] 23 | build: [ 24 | ["dune" "subst"] {pinned} 25 | [ 26 | "dune" 27 | "build" 28 | "-p" 29 | name 30 | "-j" 31 | jobs 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ] 37 | dev-repo: "git+https://github.com/rgrinberg/opium.git" 38 | -------------------------------------------------------------------------------- /opium-graphql/asset/graphiql.html: -------------------------------------------------------------------------------- 1 | 8 | 9 | 10 | 11 | 12 | 24 | 25 | 32 | 33 | 34 | 35 | 40 | 41 | 42 | 43 | 44 |
Loading...
45 | 46 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /opium-graphql/doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package opium-graphql)) 3 | -------------------------------------------------------------------------------- /opium-graphql/doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Opium GraphQL} 2 | 3 | [opium-graphql] provides Opium handlers to serve GraphQL APIs. 4 | 5 | {1 Installation} 6 | 7 | To install [opium-graphql], you can add it to your [dune-project]'s package stanza: 8 | 9 | {%html: 
 10 | (package
 11 |  (name my_app)
 12 |  (depends
 13 |   (ocaml
 14 |    (>= 4.08))
 15 |   opium
 16 |   opium-graphql))
 17 |
%} 18 | 19 | And let Dune generate the Opam file for you. Or you can add it directly to your [.opam] file: 20 | 21 | {%html: 
 22 | depends: [
 23 |   "opium"
 24 |   "opium-graphql"
 25 | ]
 26 |
%} 27 | 28 | {1 Usage} 29 | 30 | Here's a sample application that serves a schema with a node [user]: 31 | 32 | {[ 33 | open Opium 34 | 35 | module Schema = struct 36 | open Graphql_lwt 37 | 38 | type context = unit 39 | 40 | type user = 41 | { id : int 42 | ; name : string 43 | } 44 | 45 | let users = [ { id = 1; name = "Alice" }; { id = 2; name = "Bob" } ] 46 | 47 | let user : (context, user option) Graphql_lwt.Schema.typ = 48 | Schema.( 49 | obj "user" ~doc:"A user in the system" ~fields:(fun _ -> 50 | [ field 51 | "id" 52 | ~doc:"Unique user identifier" 53 | ~typ:(non_null int) 54 | ~args:Arg.[] 55 | ~resolve:(fun _info p -> p.id) 56 | ; field 57 | "name" 58 | ~typ:(non_null string) 59 | ~args:Arg.[] 60 | ~resolve:(fun _info p -> p.name) 61 | ])) 62 | ;; 63 | 64 | let schema = 65 | Graphql_lwt.Schema.( 66 | schema 67 | [ field 68 | "users" 69 | ~typ:(non_null (list (non_null user))) 70 | ~args:Arg.[] 71 | ~resolve:(fun _info () -> users) 72 | ]) 73 | ;; 74 | end 75 | 76 | let graphql = 77 | let handler = Opium_graphql.make_handler ~make_context:(fun _req -> ()) Schema.schema in 78 | Opium.App.all "/" handler 79 | ;; 80 | 81 | let graphiql = 82 | let handler = Opium_graphql.graphiql_handler ~graphql_endpoint:"/" in 83 | Opium.App.get "/graphiql" handler 84 | ;; 85 | 86 | let _ = 87 | Logs.set_reporter (Logs_fmt.reporter ()); 88 | Logs.set_level (Some Logs.Debug); 89 | App.empty |> graphql |> graphiql |> App.run_command 90 | ;; 91 | ]} 92 | 93 | The example provides two endpoints: 94 | 95 | - [/] that serves the actual GraphQL API 96 | - [/graphiql] that serves the GraphiQL tool 97 | 98 | To test the API, you can go on the GraphiQL tool and run the following query: 99 | 100 | {[ 101 | query { 102 | users { 103 | name 104 | } 105 | } 106 | ]} 107 | 108 | {1 API documentation} 109 | 110 | {!modules: 111 | Opium_graphql 112 | } 113 | -------------------------------------------------------------------------------- /opium-graphql/src/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets asset.ml) 3 | (deps 4 | (source_tree ../asset)) 5 | (action 6 | (run %{bin:ocaml-crunch} -m plain ../asset -o asset.ml))) 7 | 8 | (library 9 | (name opium_graphql) 10 | (public_name opium-graphql) 11 | (libraries opium graphql graphql-lwt lwt str)) 12 | -------------------------------------------------------------------------------- /opium-graphql/src/opium_graphql.ml: -------------------------------------------------------------------------------- 1 | module Option = struct 2 | include Option 3 | 4 | let bind t ~f = 5 | match t with 6 | | None -> None 7 | | Some x -> f x 8 | ;; 9 | 10 | let map t ~f = bind t ~f:(fun x -> Some (f x)) 11 | 12 | let first_some t t' = 13 | match t with 14 | | None -> t' 15 | | Some _ -> t 16 | ;; 17 | end 18 | 19 | module Params = struct 20 | type t = 21 | { query : string option 22 | ; variables : (string * Yojson.Basic.t) list option 23 | ; operation_name : string option 24 | } 25 | 26 | let empty = { query = None; variables = None; operation_name = None } 27 | 28 | let of_uri_exn uri = 29 | let variables = 30 | Uri.get_query_param uri "variables" 31 | |> Option.map ~f:Yojson.Basic.from_string 32 | |> Option.map ~f:Yojson.Basic.Util.to_assoc 33 | in 34 | { query = Uri.get_query_param uri "query" 35 | ; variables 36 | ; operation_name = Uri.get_query_param uri "operationName" 37 | } 38 | ;; 39 | 40 | let of_json_body_exn body = 41 | if body = "" 42 | then empty 43 | else ( 44 | let json = Yojson.Basic.from_string body in 45 | { query = Yojson.Basic.Util.(json |> member "query" |> to_option to_string) 46 | ; variables = Yojson.Basic.Util.(json |> member "variables" |> to_option to_assoc) 47 | ; operation_name = 48 | Yojson.Basic.Util.(json |> member "operationName" |> to_option to_string) 49 | }) 50 | ;; 51 | 52 | let of_graphql_body body = 53 | { query = Some body; variables = None; operation_name = None } 54 | ;; 55 | 56 | let merge t t' = 57 | { query = Option.first_some t.query t'.query 58 | ; variables = Option.first_some t.variables t'.variables 59 | ; operation_name = Option.first_some t.operation_name t'.operation_name 60 | } 61 | ;; 62 | 63 | let post_params_exn req body = 64 | let headers = req.Opium.Request.headers in 65 | match Httpaf.Headers.get headers "Content-Type" with 66 | | Some "application/graphql" -> of_graphql_body body 67 | | Some "application/json" -> of_json_body_exn body 68 | | _ -> empty 69 | ;; 70 | 71 | let of_req_exn req body = 72 | let get_params = req.Opium.Request.target |> Uri.of_string |> of_uri_exn in 73 | let post_params = post_params_exn req body in 74 | merge get_params post_params 75 | ;; 76 | 77 | let extract req body = 78 | try 79 | let params = of_req_exn req body in 80 | match params.query with 81 | | Some query -> 82 | Ok 83 | ( query 84 | , (params.variables :> (string * Graphql_parser.const_value) list option) 85 | , params.operation_name ) 86 | | None -> Error "Must provide query string" 87 | with 88 | | Yojson.Json_error msg -> Error msg 89 | ;; 90 | end 91 | 92 | module Schema = Graphql_lwt.Schema 93 | 94 | let basic_to_safe json = json |> Yojson.Basic.to_string |> Yojson.Safe.from_string 95 | 96 | let execute_query ctx schema variables operation_name query = 97 | match Graphql_parser.parse query with 98 | | Ok doc -> Schema.execute schema ctx ?variables ?operation_name doc 99 | | Error e -> Lwt.return (Error (`String e)) 100 | ;; 101 | 102 | let execute_request schema ctx req = 103 | let open Lwt.Syntax in 104 | let* body_string = Opium.Body.to_string req.Opium.Request.body in 105 | match Params.extract req body_string with 106 | | Error err -> Opium.Response.of_plain_text ~status:`Bad_request err |> Lwt.return 107 | | Ok (query, variables, operation_name) -> 108 | let+ result = execute_query ctx schema variables operation_name query in 109 | (match result with 110 | | Ok (`Response data) -> data |> basic_to_safe |> Opium.Response.of_json ~status:`OK 111 | | Ok (`Stream stream) -> 112 | Graphql_lwt.Schema.Io.Stream.close stream; 113 | let body = "Subscriptions are only supported via websocket transport" in 114 | Opium.Response.of_plain_text ~status:`Bad_request body 115 | | Error err -> err |> basic_to_safe |> Opium.Response.of_json ~status:`Bad_request) 116 | ;; 117 | 118 | let make_handler 119 | : type a. 120 | make_context:(Rock.Request.t -> a) -> a Graphql_lwt.Schema.schema -> Rock.Handler.t 121 | = 122 | fun ~make_context schema req -> 123 | match req.Opium.Request.meth with 124 | | `GET -> 125 | if 126 | Httpaf.Headers.get req.Opium.Request.headers "Connection" = Some "Upgrade" 127 | && Httpaf.Headers.get req.Opium.Request.headers "Upgrade" = Some "websocket" 128 | then 129 | (* TODO: Add subscription support when there is a good solution for websockets with 130 | Httpaf *) 131 | Opium.Response.of_plain_text 132 | ~status:`Internal_server_error 133 | "Subscriptions are not supported (yet)" 134 | |> Lwt.return 135 | else execute_request schema (make_context req) req 136 | | `POST -> execute_request schema (make_context req) req 137 | | _ -> Opium.Response.make ~status:`Method_not_allowed () |> Lwt.return 138 | ;; 139 | 140 | let graphiql_etag = 141 | Asset.read "graphiql.html" 142 | |> Option.get 143 | |> Digestif.MD5.digest_string 144 | |> Digestif.MD5.to_raw_string 145 | |> Base64.encode_exn 146 | ;; 147 | 148 | let make_graphiql_handler ~graphql_endpoint req = 149 | let accept_html = 150 | match Httpaf.Headers.get req.Opium.Request.headers "accept" with 151 | | None -> false 152 | | Some s -> List.mem "text/html" (String.split_on_char ',' s) 153 | in 154 | let h = 155 | Opium.Handler.serve 156 | ~etag:graphiql_etag 157 | ~mime_type:"text/html; charset=utf-8" 158 | (fun () -> 159 | match Asset.read "graphiql.html" with 160 | | None -> Lwt.return_error `Internal_server_error 161 | | Some body -> 162 | let regexp = Str.regexp_string "%%GRAPHQL_API%%" in 163 | let body = Str.global_replace regexp graphql_endpoint body in 164 | Lwt.return_ok (Opium.Body.of_string body)) 165 | in 166 | if accept_html 167 | then h req 168 | else 169 | Opium.Response.of_plain_text ~status:`Bad_request "Clients must accept text/html" 170 | |> Lwt.return 171 | ;; 172 | -------------------------------------------------------------------------------- /opium-graphql/src/opium_graphql.mli: -------------------------------------------------------------------------------- 1 | (** [execute_request schema context request] executes the request [request] on the schema 2 | [schema] with the context [context]. 3 | 4 | You most likely want to use [make_handler] instead of this, but if can be useful for 5 | unit tests. *) 6 | val execute_request 7 | : 'a Graphql_lwt.Schema.schema 8 | -> 'a 9 | -> Rock.Request.t 10 | -> Rock.Response.t Lwt.t 11 | 12 | (** [make_handler ?make_context] builds a [Rock] handler that serves a GraphQL API. 13 | 14 | [make_context] is the callback that will create the GraphQL context for each request 15 | and will be passed to resolvers. *) 16 | val make_handler 17 | : make_context:(Rock.Request.t -> 'a) 18 | -> 'a Graphql_lwt.Schema.schema 19 | -> Rock.Handler.t 20 | 21 | (** [make_graphiql_handler ~graphql_endpoint] builds a [Rock] handler that serves an HTML 22 | page with the GraphiQL tool. 23 | 24 | The [graphql_endpoint] is the URI of the GraphQL API. For instance, if the API is at 25 | the root on the same server, [graphql_endpoint] is [/]. 26 | 27 | The HTML content of the tool is served from the memory. An [ETag] header is added to 28 | the response. *) 29 | val make_graphiql_handler : graphql_endpoint:string -> Rock.Handler.t 30 | -------------------------------------------------------------------------------- /opium-graphql/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names request_test) 3 | (libraries alcotest alcotest-lwt opium opium-graphql) 4 | (package opium-graphql)) 5 | -------------------------------------------------------------------------------- /opium-graphql/test/request_test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let schema = 4 | Graphql_lwt.Schema.( 5 | schema 6 | [ field 7 | "hello" 8 | ~typ:(non_null string) 9 | ~args:Arg.[ arg "name" ~typ:string ] 10 | ~resolve:(fun _ () -> function 11 | | None -> "world" 12 | | Some name -> name) 13 | ]) 14 | ;; 15 | 16 | let response_check = Alcotest.of_pp Opium.Response.pp_hum 17 | 18 | let check_body actual expected = 19 | Opium.Body.to_string actual >|= fun body -> Alcotest.(check string) "body" body expected 20 | ;; 21 | 22 | let default_uri = "/" 23 | let json_content_type = Opium.Headers.of_list [ "Content-Type", "application/json" ] 24 | let graphql_content_type = Opium.Headers.of_list [ "Content-Type", "application/graphql" ] 25 | let default_response_body = `Assoc [ "data", `Assoc [ "hello", `String "world" ] ] 26 | let graphql_handler = Opium_graphql.make_handler ~make_context:(fun _ -> ()) schema 27 | 28 | let test_case ~req ~rsp = 29 | let open Lwt.Syntax in 30 | let+ response = graphql_handler req in 31 | Alcotest.check response_check "response" response rsp 32 | ;; 33 | 34 | let suite = 35 | [ ( "POST with empty body" 36 | , `Quick 37 | , fun () -> 38 | test_case 39 | ~req:(Opium.Request.make default_uri `POST) 40 | ~rsp: 41 | (Opium.Response.of_plain_text 42 | ~status:`Bad_request 43 | "Must provide query string") ) 44 | ; ( "POST with json body" 45 | , `Quick 46 | , fun () -> 47 | let body = 48 | Opium.Body.of_string 49 | (Yojson.Safe.to_string (`Assoc [ "query", `String "{ hello }" ])) 50 | in 51 | test_case 52 | ~req:(Opium.Request.make ~headers:json_content_type ~body default_uri `POST) 53 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 54 | ; ( "POST with graphql body" 55 | , `Quick 56 | , fun () -> 57 | let body = Opium.Body.of_string "{ hello }" in 58 | test_case 59 | ~req:(Opium.Request.make ~headers:graphql_content_type ~body default_uri `POST) 60 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 61 | ; ( "GET with empty query string" 62 | , `Quick 63 | , fun () -> 64 | test_case 65 | ~req:(Opium.Request.make default_uri `GET) 66 | ~rsp: 67 | (Opium.Response.of_plain_text 68 | ~status:`Bad_request 69 | "Must provide query string") ) 70 | ; ( "GET with query" 71 | , `Quick 72 | , fun () -> 73 | let query = "{ hello }" in 74 | let query = Some [ "query", [ query ] ] in 75 | let uri = Uri.with_uri ~query (Uri.of_string default_uri) in 76 | test_case 77 | ~req:(Opium.Request.make (Uri.to_string uri) `GET) 78 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 79 | ; ( "operation name in JSON body" 80 | , `Quick 81 | , fun () -> 82 | let body = 83 | Opium.Body.of_string 84 | (Yojson.Safe.to_string 85 | (`Assoc 86 | [ ( "query" 87 | , `String 88 | "query A { hello(name: \"world\") } query B { hello(name: \ 89 | \"fail\") }" ) 90 | ; "operationName", `String "A" 91 | ])) 92 | in 93 | test_case 94 | ~req:(Opium.Request.make ~headers:json_content_type ~body default_uri `POST) 95 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 96 | ; ( "operation name in query string" 97 | , `Quick 98 | , fun () -> 99 | let body = 100 | Opium.Body.of_string 101 | (Yojson.Safe.to_string 102 | (`Assoc 103 | [ ( "query" 104 | , `String 105 | "query A { hello(name: \"world\") } query B { hello(name: \ 106 | \"fail\") }" ) 107 | ])) 108 | in 109 | let query = Some [ "operationName", [ "A" ] ] in 110 | let uri = Uri.with_uri ~query (Uri.of_string default_uri) in 111 | test_case 112 | ~req: 113 | (Opium.Request.make 114 | ~headers:json_content_type 115 | ~body 116 | (Uri.to_string uri) 117 | `POST) 118 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 119 | ; ( "variables in JSON body" 120 | , `Quick 121 | , fun () -> 122 | let body = 123 | Opium.Body.of_string 124 | (Yojson.Safe.to_string 125 | (`Assoc 126 | [ "query", `String "query A($name: String!) { hello(name: $name) }" 127 | ; "variables", `Assoc [ "name", `String "world" ] 128 | ])) 129 | in 130 | test_case 131 | ~req:(Opium.Request.make ~headers:json_content_type ~body default_uri `POST) 132 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 133 | ; ( "variables in query string" 134 | , `Quick 135 | , fun () -> 136 | let body = 137 | Opium.Body.of_string 138 | (Yojson.Safe.to_string 139 | (`Assoc 140 | [ "query", `String "query A($name: String!) { hello(name: $name) }" ])) 141 | in 142 | let query = 143 | Some [ "operationName", [ "A" ]; "variables", [ "{\"name\":\"world\"}" ] ] 144 | in 145 | let uri = Uri.with_uri ~query (Uri.of_string default_uri) in 146 | test_case 147 | ~req: 148 | (Opium.Request.make 149 | ~headers:json_content_type 150 | ~body 151 | (Uri.to_string uri) 152 | `POST) 153 | ~rsp:(Opium.Response.of_json ~status:`OK default_response_body) ) 154 | ] 155 | ;; 156 | 157 | let () = Lwt_main.run @@ Alcotest_lwt.run "opium-graphql" [ "request", suite ] 158 | -------------------------------------------------------------------------------- /opium-testing.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Testing library for Opium" 4 | description: 5 | "A library that provides helpers to easily test your Opium applications." 6 | maintainer: ["Rudi Grinberg "] 7 | authors: ["Rudi Grinberg" "Anurag Soni" "Thibaut Mattio"] 8 | license: "MIT" 9 | homepage: "https://github.com/rgrinberg/opium" 10 | doc: "https://rgrinberg.github.io/opium/" 11 | bug-reports: "https://github.com/rgrinberg/opium/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "ocaml" {>= "4.08"} 15 | "opium" {= version} 16 | "alcotest" 17 | "alcotest-lwt" 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {pinned} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "@install" 30 | "@runtest" {with-test} 31 | "@doc" {with-doc} 32 | ] 33 | ] 34 | dev-repo: "git+https://github.com/rgrinberg/opium.git" 35 | -------------------------------------------------------------------------------- /opium-testing/doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package opium-testing)) 3 | -------------------------------------------------------------------------------- /opium-testing/doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Opium Testing} 2 | 3 | [opium-testing] provides helpers to easily test Opium applications with Alcotest. 4 | 5 | {1 Installation} 6 | 7 | To install [opium-testing], you can add it to your [dune-project]'s package stanza: 8 | 9 | {%html: 
10 | (package
11 |  (name my_app)
12 |  (depends
13 |   (ocaml
14 |    (>= 4.08))
15 |   (dune
16 |    (>= 2.0))
17 |   rock
18 |   (alcotest :with-test)
19 |   (alcotest-lwt :with-test)
20 |   (opium-testing :with-test)))
21 |
%} 22 | 23 | And let Dune generate the Opam file for you. Or you can add it directly to your [.opam] file: 24 | 25 | {%html: 
26 | depends: [
27 |   "alcotest" {with-test}
28 |   "alcotest-lwt" {with-test}
29 |   "opium-testing" {with-test}
30 | ]
31 |
%} 32 | 33 | {1 Usage} 34 | 35 | Here's a sample unit test that tests if the response is the one expected. 36 | 37 | {[ 38 | open Alcotest 39 | open Lwt.Syntax 40 | open Rock 41 | open Opium_testing 42 | 43 | let test_case n f = Alcotest_lwt.test_case n `Quick (fun _switch () -> f ()) 44 | 45 | let handle_request = handle_request My_app.app 46 | 47 | let suite = 48 | [ ( "POST /create-user" 49 | , [ test_case "redirects to show when data is valid" (fun () -> 50 | let req = 51 | Request.of_json 52 | ~body:(`Assoc [ "name", `String "Tom" ]) 53 | "/create-user" 54 | `POST 55 | in 56 | let+ res = handle_request req in 57 | check_status `Found res.status) 58 | ; test_case "renders errors when data is invalid" (fun () -> 59 | let req = 60 | Request.of_json 61 | ~body:(`Assoc [ "invalid-key", `String "invald-value" ]) 62 | "/create-user" 63 | `POST 64 | in 65 | let+ res = handle_request req in 66 | check_status `Bad_request res.status; 67 | check_body_contains "Invalid data" res.body) 68 | ] ) 69 | ] 70 | ;; 71 | 72 | let () = Lwt_main.run @@ Alcotest_lwt.run "User Handler" suite 73 | ]} 74 | 75 | {1 API documentation} 76 | 77 | {!modules: 78 | Opium_testing 79 | } 80 | -------------------------------------------------------------------------------- /opium-testing/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name opium_testing) 3 | (public_name opium-testing) 4 | (libraries str opium lwt alcotest alcotest-lwt)) 5 | -------------------------------------------------------------------------------- /opium-testing/src/opium_testing.ml: -------------------------------------------------------------------------------- 1 | module Testable = struct 2 | let status = Alcotest.of_pp Opium.Status.pp 3 | let meth = Alcotest.of_pp Opium.Method.pp 4 | let version = Alcotest.of_pp Opium.Version.pp 5 | let body = Alcotest.of_pp Opium.Body.pp 6 | let request = Alcotest.of_pp Opium.Request.pp 7 | let response = Alcotest.of_pp Opium.Response.pp 8 | let cookie = Alcotest.of_pp Opium.Cookie.pp 9 | end 10 | 11 | let handle_request app = 12 | let open Lwt.Syntax in 13 | let service = Opium.App.to_handler app in 14 | let request_handler request = 15 | let+ ({ Opium.Response.body; headers; _ } as response) = service request in 16 | let length = Opium.Body.length body in 17 | let headers = 18 | match length with 19 | | None -> Opium.Headers.add_unless_exists headers "Transfer-Encoding" "chunked" 20 | | Some l -> 21 | Opium.Headers.add_unless_exists headers "Content-Length" (Int64.to_string l) 22 | in 23 | { response with headers } 24 | in 25 | request_handler 26 | ;; 27 | 28 | let check_status ?msg expected t = 29 | let message = 30 | match msg with 31 | | Some msg -> msg 32 | | None -> Format.asprintf "HTTP status is %d" (Opium.Status.to_code expected) 33 | in 34 | Alcotest.check Testable.status message expected t 35 | ;; 36 | 37 | let check_status' ?msg ~expected ~actual () = check_status ?msg expected actual 38 | 39 | let check_meth ?msg expected t = 40 | let message = 41 | match msg with 42 | | Some msg -> msg 43 | | None -> Format.asprintf "HTTP method is %s" (Opium.Method.to_string expected) 44 | in 45 | Alcotest.check Testable.meth message expected t 46 | ;; 47 | 48 | let check_meth' ?msg ~expected ~actual () = check_meth ?msg expected actual 49 | 50 | let check_version ?msg expected t = 51 | let message = 52 | match msg with 53 | | Some msg -> msg 54 | | None -> Format.asprintf "HTTP version is %s" (Opium.Version.to_string expected) 55 | in 56 | Alcotest.check Testable.version message expected t 57 | ;; 58 | 59 | let check_version' ?msg ~expected ~actual () = check_version ?msg expected actual 60 | 61 | let check_body ?msg expected t = 62 | let message = 63 | match msg with 64 | | Some msg -> msg 65 | | None -> "bodies are equal" 66 | in 67 | Alcotest.check Testable.body message expected t 68 | ;; 69 | 70 | let check_body' ?msg ~expected ~actual () = check_body ?msg expected actual 71 | 72 | let check_request ?msg expected t = 73 | let message = 74 | match msg with 75 | | Some msg -> msg 76 | | None -> "requests are equal" 77 | in 78 | Alcotest.check Testable.request message expected t 79 | ;; 80 | 81 | let check_request' ?msg ~expected ~actual () = check_request ?msg expected actual 82 | 83 | let check_response ?msg expected t = 84 | let message = 85 | match msg with 86 | | Some msg -> msg 87 | | None -> "responses are equal" 88 | in 89 | Alcotest.check Testable.response message expected t 90 | ;; 91 | 92 | let check_response' ?msg ~expected ~actual () = check_response ?msg expected actual 93 | 94 | let string_contains s1 s2 = 95 | let re = Str.regexp_string s2 in 96 | try 97 | ignore (Str.search_forward re s1 0); 98 | true 99 | with 100 | | Not_found -> false 101 | ;; 102 | 103 | let check_body_contains ?msg s body = 104 | let message = 105 | match msg with 106 | | Some msg -> msg 107 | | None -> "response body contains" ^ s 108 | in 109 | let open Lwt.Syntax in 110 | let+ body = body |> Opium.Body.copy |> Opium.Body.to_string in 111 | Alcotest.check Alcotest.bool message true (string_contains body s) 112 | ;; 113 | 114 | let check_cookie ?msg expected t = 115 | let message = 116 | match msg with 117 | | Some msg -> msg 118 | | None -> "cookies are equal" 119 | in 120 | Alcotest.check Testable.cookie message expected t 121 | ;; 122 | 123 | let check_cookie' ?msg ~expected ~actual () = check_cookie ?msg expected actual 124 | -------------------------------------------------------------------------------- /opium-testing/src/opium_testing.mli: -------------------------------------------------------------------------------- 1 | (** This module provides helpers to easily test Opium applications with Alcotest. *) 2 | 3 | (** {3 [Testable]} *) 4 | 5 | (** Collection of [Alcotest] testables for [Opium] types. *) 6 | module Testable : sig 7 | (** An {!Alcotest.testable} for {!Opium.Status.t} instances. *) 8 | val status : Opium.Status.t Alcotest.testable 9 | 10 | (** An {!Alcotest.testable} for {!Opium.Method.t} instances. *) 11 | val meth : Opium.Method.t Alcotest.testable 12 | 13 | (** An {!Alcotest.testable} for {!Opium.Version.t} instances. *) 14 | val version : Opium.Version.t Alcotest.testable 15 | 16 | (** An {!Alcotest.testable} for {!Opium.Body.t} instances. *) 17 | val body : Opium.Body.t Alcotest.testable 18 | 19 | (** An {!Alcotest.testable} for {!Opium.Request.t} instances. *) 20 | val request : Opium.Request.t Alcotest.testable 21 | 22 | (** An {!Alcotest.testable} for {!Opium.Response.t} instances. *) 23 | val response : Opium.Response.t Alcotest.testable 24 | 25 | (** An {!Alcotest.testable} for {!Opium.Cookie.t} instances. *) 26 | val cookie : Opium.Cookie.t Alcotest.testable 27 | end 28 | 29 | (** {3 [handle_request]} *) 30 | 31 | (** [handle_request app request response] processes a request [request] with the given 32 | Opium application [app]. 33 | 34 | It processes the request the same [Opium.Server_connection.run] would and returns the 35 | generated response. *) 36 | val handle_request : Opium.App.t -> Opium.Request.t -> Opium.Response.t Lwt.t 37 | 38 | (** {3 [check_status]} *) 39 | 40 | (** [check_status ?msg t1 t2] checks that the status [t1] and [t2] are equal. *) 41 | val check_status : ?msg:string -> Opium.Status.t -> Opium.Status.t -> unit 42 | 43 | (** {3 [check_status']} *) 44 | 45 | (** [check_status' ?msg t1 t2] checks that the status [t1] and [t2] are equal. 46 | 47 | This is a labeled variant of {!check_status} *) 48 | val check_status' 49 | : ?msg:string 50 | -> expected:Opium.Status.t 51 | -> actual:Opium.Status.t 52 | -> unit 53 | -> unit 54 | 55 | (** {3 [check_meth]} *) 56 | 57 | (** [check_meth ?msg t1 t2] checks that the method [t1] and [t2] are equal. *) 58 | val check_meth : ?msg:string -> Opium.Method.t -> Opium.Method.t -> unit 59 | 60 | (** {3 [check_meth']} *) 61 | 62 | (** [check_meth' ?msg t1 t2] checks that the method [t1] and [t2] are equal. 63 | 64 | This is a labeled variant of {!check_meth} *) 65 | val check_meth' 66 | : ?msg:string 67 | -> expected:Opium.Method.t 68 | -> actual:Opium.Method.t 69 | -> unit 70 | -> unit 71 | 72 | (** {3 [check_version]} *) 73 | 74 | (** [check_version ?msg t1 t2] checks that the version [t1] and [t2] are equal. *) 75 | val check_version : ?msg:string -> Opium.Version.t -> Opium.Version.t -> unit 76 | 77 | (** {3 [check_version']} *) 78 | 79 | (** [check_version' ?msg t1 t2] checks that the version [t1] and [t2] are equal. 80 | 81 | This is a labeled variant of {!check_version} *) 82 | val check_version' 83 | : ?msg:string 84 | -> expected:Opium.Version.t 85 | -> actual:Opium.Version.t 86 | -> unit 87 | -> unit 88 | 89 | (** {3 [check_body]} *) 90 | 91 | (** [check_body ?msg t1 t2] checks that the body [t1] and [t2] are equal. *) 92 | val check_body : ?msg:string -> Opium.Body.t -> Opium.Body.t -> unit 93 | 94 | (** {3 [check_body']} *) 95 | 96 | (** [check_body' ?msg t1 t2] checks that the body [t1] and [t2] are equal. 97 | 98 | This is a labeled variant of {!check_body} *) 99 | val check_body' 100 | : ?msg:string 101 | -> expected:Opium.Body.t 102 | -> actual:Opium.Body.t 103 | -> unit 104 | -> unit 105 | 106 | (** {3 [check_request]} *) 107 | 108 | (** [check_request ?msg t1 t2] checks that the request [t1] and [t2] are equal. *) 109 | val check_request : ?msg:string -> Opium.Request.t -> Opium.Request.t -> unit 110 | 111 | (** {3 [check_request']} *) 112 | 113 | (** [check_request' ?msg t1 t2] checks that the request [t1] and [t2] are equal. 114 | 115 | This is a labeled variant of {!check_request} *) 116 | val check_request' 117 | : ?msg:string 118 | -> expected:Opium.Request.t 119 | -> actual:Opium.Request.t 120 | -> unit 121 | -> unit 122 | 123 | (** {3 [check_response]} *) 124 | 125 | (** [check_response ?msg t1 t2] checks that the response [t1] and [t2] are equal. *) 126 | val check_response : ?msg:string -> Opium.Response.t -> Opium.Response.t -> unit 127 | 128 | (** {3 [check_response']} *) 129 | 130 | (** [check_response' ?msg t1 t2] checks that the response [t1] and [t2] are equal. 131 | 132 | This is a labeled variant of {!check_response} *) 133 | val check_response' 134 | : ?msg:string 135 | -> expected:Opium.Response.t 136 | -> actual:Opium.Response.t 137 | -> unit 138 | -> unit 139 | 140 | (** {3 [check_cookie]} *) 141 | 142 | (** [check_cookie ?msg t1 t2] checks that the cookie [t1] and [t2] are equal. *) 143 | val check_cookie : ?msg:string -> Opium.Cookie.t -> Opium.Cookie.t -> unit 144 | 145 | (** {3 [check_cookie']} *) 146 | 147 | (** [check_cookie' ?msg t1 t2] checks that the cookie [t1] and [t2] are equal. 148 | 149 | This is a labeled variant of {!check_cookie} *) 150 | val check_cookie' 151 | : ?msg:string 152 | -> expected:Opium.Cookie.t 153 | -> actual:Opium.Cookie.t 154 | -> unit 155 | -> unit 156 | 157 | (** {3 [check_body_contains]} *) 158 | 159 | (** [check_body_contains ?msg s t] checks that the body [t] contains the string [s]. *) 160 | val check_body_contains : ?msg:string -> string -> Opium.Body.t -> unit Lwt.t 161 | -------------------------------------------------------------------------------- /opium.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml web framework" 4 | description: 5 | "Opium is a web framework for OCaml that provides everything you need to build safe, fast and extensible web applications." 6 | maintainer: ["Rudi Grinberg "] 7 | authors: ["Rudi Grinberg" "Anurag Soni" "Thibaut Mattio"] 8 | license: "MIT" 9 | homepage: "https://github.com/rgrinberg/opium" 10 | doc: "https://rgrinberg.github.io/opium/" 11 | bug-reports: "https://github.com/rgrinberg/opium/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "ocaml" {>= "4.08"} 15 | "rock" {= version} 16 | "lwt" {>= "5.3.0"} 17 | "httpaf-lwt-unix" 18 | "logs" 19 | "fmt" 20 | "mtime" 21 | "cmdliner" 22 | "ptime" 23 | "magic-mime" 24 | "yojson" 25 | "tyxml" 26 | "digestif" 27 | "base64" {>= "3.0.0"} 28 | "astring" 29 | "re" 30 | "uri" 31 | "multipart-form-data" 32 | "result" {>= "1.5"} 33 | "odoc" {with-doc} 34 | "alcotest" {with-test} 35 | "alcotest-lwt" {with-test} 36 | ] 37 | build: [ 38 | ["dune" "subst"] {pinned} 39 | [ 40 | "dune" 41 | "build" 42 | "-p" 43 | name 44 | "-j" 45 | jobs 46 | "@install" 47 | "@runtest" {with-test} 48 | "@doc" {with-doc} 49 | ] 50 | ] 51 | dev-repo: "git+https://github.com/rgrinberg/opium.git" 52 | -------------------------------------------------------------------------------- /opium/doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package opium)) 3 | -------------------------------------------------------------------------------- /opium/doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Opium} 2 | 3 | Welcome to Opium's documentation! 4 | 5 | {1 Overview} 6 | 7 | Opium is a web framework for OCaml. 8 | 9 | {1 Installation} 10 | 11 | In order to build an Opium app, you will need to install a few dependencies on your system. You can use either Esy to Opam for this. 12 | 13 | {2 Install with Opam} 14 | 15 | To install Opium with [opam], you can run [opam install opium]. You can then run [opam info opium] to make sure the library has been installed correctly. 16 | 17 | {2 Install with Esy} 18 | 19 | To install Opium with [esy], you can run [esy add @opam/opium], this will add an entry ["@opam/opium": "*"] to your [package.json] and install the dependency. You can then run [esy ls-modules] to make sure the library has been installed correctly. 20 | 21 | {2 Use in a Dune project} 22 | 23 | To use Opium in your dune project, you can add [opium] to the [libraries] stanza in your dune file. 24 | 25 | If you are building a library, this will look like this: 26 | 27 | {[ 28 | (library 29 | (public_name mylib) 30 | (libraries opium)) 31 | ]} 32 | 33 | And for an executable: 34 | 35 | {[ 36 | (executable 37 | (public_name myexe) 38 | (libraries opium)) 39 | ]} 40 | 41 | That's it, you can now start using [Opium]! 42 | 43 | {1 Getting Started} 44 | 45 | Here is an example of a simple Opium application: 46 | 47 | {[ 48 | open Opium 49 | 50 | let hello _req = Response.of_plain_text "Hello World" |> Lwt.return 51 | 52 | let greet req = 53 | let name = Router.param req "name" in 54 | Printf.sprintf "Hello, %s" name |> Response.of_plain_text |> Lwt.return 55 | 56 | let () = 57 | App.empty 58 | |> App.get "/" hello 59 | |> App.get "/greet/:name" greet 60 | |> App.run_command 61 | |> ignore 62 | ]} 63 | 64 | When run, the executable will start an HTTP server with two endpoints: 65 | 66 | - [/] will return a [text/plain] response with the content ["Hello World"] 67 | - [/greet/:name] will return a [text/plain] response with a greeting of the name passed in the URL 68 | 69 | {1 API documentation} 70 | 71 | {!modules: 72 | Opium 73 | } 74 | -------------------------------------------------------------------------------- /opium/src/app.mli: -------------------------------------------------------------------------------- 1 | (** An opium app provides a set of convenience functions and types to construct a rock 2 | app. 3 | 4 | - Re-exporting common functions needed in handlers 5 | - Easy handling of routes and bodies 6 | - Automatic generation of a command line app *) 7 | 8 | (** An opium app is a simple builder wrapper around a rock app *) 9 | type t 10 | 11 | (** [to_handler t] converts the app t to a [Rock] handler. *) 12 | val to_handler : t -> Rock.Handler.t 13 | 14 | (** A basic empty app *) 15 | val empty : t 16 | 17 | (** A builder is a function that transforms an [app] by adding some functionality. 18 | Builders are usuallys composed with a base app using (|>) to create a full app *) 19 | type builder = t -> t 20 | 21 | val host : string -> builder 22 | 23 | (** [backlog] specifies the maximum number of clients that can have a pending connection 24 | request to the Opium server. *) 25 | val backlog : int -> builder 26 | 27 | val debug : bool -> builder 28 | val verbose : bool -> builder 29 | val port : int -> builder 30 | val jobs : int -> builder 31 | val cmd_name : string -> builder 32 | 33 | (** [not_found] accepts a regular Opium handler that will be used instead of the default 34 | 404 handler. *) 35 | val not_found : (Request.t -> (Headers.t * Body.t) Lwt.t) -> builder 36 | 37 | val with_error_handler : Rock.Server_connection.error_handler -> builder 38 | 39 | (** A route is a function that returns a buidler that hooks up a handler to a url mapping 40 | *) 41 | type route = string -> Rock.Handler.t -> builder 42 | 43 | (** Method specific routes *) 44 | 45 | val get : route 46 | val post : route 47 | val delete : route 48 | val put : route 49 | val options : route 50 | val head : route 51 | val patch : route 52 | 53 | (** any [methods] will bind a route to any http method inside of [methods] *) 54 | val any : Method.t list -> route 55 | 56 | (** all [methods] will bind a route to a URL regardless of the http method. You may escape 57 | the actual method used from the request passed. *) 58 | val all : route 59 | 60 | val action : Method.t -> route 61 | val middleware : Rock.Middleware.t -> builder 62 | 63 | (** Start an opium server. The thread returned can be cancelled to shutdown the server *) 64 | val start : t -> Lwt_io.server Lwt.t 65 | 66 | (** Start an opium server with multiple processes. *) 67 | val start_multicore : t -> unit 68 | 69 | (** Create a cmdliner command from an app and run lwt's event loop *) 70 | val run_command : t -> unit 71 | 72 | (* Run a cmdliner command from an app. Does not launch Lwt's event loop. `Error is 73 | returned if the command line arguments are incorrect. `Not_running is returned if the 74 | command was completed without the server being launched *) 75 | val run_command' : t -> [> `Ok of unit Lwt.t | `Error | `Not_running ] 76 | 77 | (** Create a cmdliner command from an app and spawn with multiple processes. *) 78 | val run_multicore : t -> unit 79 | -------------------------------------------------------------------------------- /opium/src/auth.ml: -------------------------------------------------------------------------------- 1 | module Challenge = struct 2 | type t = Basic of string 3 | 4 | let t_of_sexp = 5 | let open Sexplib0.Sexp in 6 | function 7 | | List [ Atom "basic"; Atom s ] -> Basic s 8 | | _ -> failwith "invalid challenge sexp" 9 | ;; 10 | 11 | let sexp_of_t = 12 | let open Sexplib0.Sexp in 13 | function 14 | | Basic s -> List [ Atom "basic"; Atom s ] 15 | ;; 16 | end 17 | 18 | module Credential = struct 19 | type t = 20 | | Basic of string * string (* username, password *) 21 | | Other of string 22 | 23 | let t_of_sexp = 24 | let open Sexplib0.Sexp in 25 | function 26 | | List [ Atom "basic"; Atom u; Atom p ] -> Basic (u, p) 27 | | _ -> failwith "invalid credential sexp" 28 | ;; 29 | 30 | let sexp_of_t = 31 | let open Sexplib0.Sexp in 32 | function 33 | | Basic (u, p) -> List [ Atom "basic"; Atom u; Atom p ] 34 | | Other s -> List [ Atom "other"; Atom s ] 35 | ;; 36 | end 37 | 38 | let string_of_credential (cred : Credential.t) = 39 | match cred with 40 | | Basic (user, pass) -> 41 | "Basic " ^ Base64.encode_string (Printf.sprintf "%s:%s" user pass) 42 | | Other buf -> buf 43 | ;; 44 | 45 | let credential_of_string (buf : string) : Credential.t = 46 | try 47 | let b64 = Scanf.sscanf buf "Basic %s" (fun b -> b) in 48 | match Stringext.split ~on:':' (Base64.decode_exn b64) ~max:2 with 49 | | [ user; pass ] -> Basic (user, pass) 50 | | _ -> Other buf 51 | with 52 | | _ -> Other buf 53 | ;; 54 | 55 | let string_of_challenge = function 56 | | Challenge.Basic realm -> Printf.sprintf "Basic realm=\"%s\"" realm 57 | ;; 58 | -------------------------------------------------------------------------------- /opium/src/auth.mli: -------------------------------------------------------------------------------- 1 | (** Authentication functions to work with common HTTP authentication methods. *) 2 | 3 | module Challenge : sig 4 | type t = Basic of string 5 | 6 | (** {3 [t_of_sexp]} *) 7 | 8 | (** [t_of_sexp sexp] parses the s-expression [sexp] into a challenge *) 9 | val t_of_sexp : Sexplib0.Sexp.t -> t 10 | 11 | (** {3 [sexp_of_t]} *) 12 | 13 | (** [sexp_of_t t] converts the challenge [t] to an s-expression *) 14 | val sexp_of_t : t -> Sexplib0.Sexp.t 15 | end 16 | 17 | module Credential : sig 18 | type t = 19 | | Basic of string * string (* username, password *) 20 | | Other of string 21 | 22 | (** {3 [t_of_sexp]} *) 23 | 24 | (** [t_of_sexp sexp] parses the s-expression [sexp] into credentials *) 25 | val t_of_sexp : Sexplib0.Sexp.t -> t 26 | 27 | (** {3 [sexp_of_t]} *) 28 | 29 | (** [sexp_of_t t] converts the credentials [t] to an s-expression *) 30 | val sexp_of_t : t -> Sexplib0.Sexp.t 31 | end 32 | 33 | (** {3 [string_of_credential]} *) 34 | 35 | (** [string_of_credential cred] converts the credentials into a string usable in the 36 | [Authorization] header. *) 37 | val string_of_credential : Credential.t -> string 38 | 39 | (** {3 [credential_of_string]} *) 40 | 41 | (** [credential_of_string s] parses a string from the [Authorization] header into 42 | credentials. *) 43 | val credential_of_string : string -> Credential.t 44 | 45 | (** {3 [string_of_challenge]} *) 46 | 47 | (** [string_of_challenge challenge] converts the challenge into a string usable in the 48 | [WWW-Authenticate] response header. *) 49 | val string_of_challenge : Challenge.t -> string 50 | -------------------------------------------------------------------------------- /opium/src/body.ml: -------------------------------------------------------------------------------- 1 | include Rock.Body 2 | 3 | let log_src = Logs.Src.create "opium.body.of_file" 4 | 5 | module Log = (val Logs.src_log log_src : Logs.LOG) 6 | 7 | exception Isnt_a_file 8 | 9 | let of_file fname = 10 | let open Lwt.Syntax in 11 | (* TODO: allow buffer size to be configurable *) 12 | let bufsize = 4096 in 13 | Lwt.catch 14 | (fun () -> 15 | let* s = Lwt_unix.stat fname in 16 | let* () = 17 | if Unix.(s.st_kind <> S_REG) then Lwt.fail Isnt_a_file else Lwt.return_unit 18 | in 19 | let* ic = 20 | Lwt_io.open_file 21 | ~buffer:(Lwt_bytes.create bufsize) 22 | ~flags:[ O_RDONLY ] 23 | ~mode:Lwt_io.input 24 | fname 25 | in 26 | let+ size = Lwt_io.length ic in 27 | let stream = 28 | Lwt_stream.from (fun () -> 29 | Lwt.catch 30 | (fun () -> 31 | let+ b = Lwt_io.read ~count:bufsize ic in 32 | match b with 33 | | "" -> None 34 | | buf -> Some buf) 35 | (fun exn -> 36 | Log.warn (fun m -> 37 | m "Error while reading file %s. %s" fname (Printexc.to_string exn)); 38 | Lwt.return_none)) 39 | in 40 | Lwt.on_success (Lwt_stream.closed stream) (fun () -> 41 | Lwt.async (fun () -> Lwt_io.close ic)); 42 | Some (of_stream ~length:size stream)) 43 | (fun e -> 44 | match e with 45 | | Isnt_a_file | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return None 46 | | exn -> 47 | Logs.err (fun m -> 48 | m "Unknown error while serving file %s. %s" fname (Printexc.to_string exn)); 49 | Lwt.fail exn) 50 | ;; 51 | -------------------------------------------------------------------------------- /opium/src/body.mli: -------------------------------------------------------------------------------- 1 | (** Represents an HTTP request or response body. *) 2 | 3 | type content = 4 | [ `Empty 5 | | `String of string 6 | | `Bigstring of Bigstringaf.t 7 | | (* TODO: switch to a iovec based stream *) 8 | `Stream of string Lwt_stream.t 9 | ] 10 | 11 | (** [t] represents an HTTP message body. *) 12 | type t = Rock.Body.t = 13 | { length : Int64.t option 14 | ; content : content 15 | } 16 | 17 | (** {1 Constructor} *) 18 | 19 | (** [of_string] creates a fixed length body from a string. *) 20 | val of_string : string -> t 21 | 22 | (** [of_bigstring] creates a fixed length body from a bigstring. *) 23 | val of_bigstring : Bigstringaf.t -> t 24 | 25 | (** [of_stream] takes a [string Lwt_stream.t] and creates a HTTP body from it. *) 26 | val of_stream : ?length:Int64.t -> string Lwt_stream.t -> t 27 | 28 | (** [of_file path] creates a response body by reading the file at [path]. *) 29 | val of_file : string -> t option Lwt.t 30 | 31 | (** [empty] represents a body of size 0L. *) 32 | val empty : t 33 | 34 | (** [copy t] creates a new instance of the body [t]. If the body is a stream, it is be 35 | duplicated safely and the initial stream will remain untouched. *) 36 | val copy : t -> t 37 | 38 | (** {1 Decoders} *) 39 | 40 | (** [to_string t] returns a promise that will eventually be filled with a string 41 | representation of the body. *) 42 | val to_string : t -> string Lwt.t 43 | 44 | (** [to_stream t] converts the body to a [string Lwt_stream.t]. *) 45 | val to_stream : t -> string Lwt_stream.t 46 | 47 | (** {1 Getters and Setters} *) 48 | 49 | val length : t -> Int64.t option 50 | 51 | (** {1 Utilities} *) 52 | 53 | (** [drain t] will repeatedly read values from the body stream and discard them. *) 54 | val drain : t -> unit Lwt.t 55 | 56 | (** [sexp_of_t t] converts the body [t] to an s-expression *) 57 | val sexp_of_t : t -> Sexplib0.Sexp.t 58 | 59 | (** [pp] formats the body [t] as an s-expression *) 60 | val pp : Format.formatter -> t -> unit 61 | [@@ocaml.toplevel_printer] 62 | 63 | (** [pp_hum] formats the body [t] as an string. 64 | 65 | If the body content is a stream, the pretty printer will output the value [""]*) 66 | val pp_hum : Format.formatter -> t -> unit 67 | [@@ocaml.toplevel_printer] 68 | -------------------------------------------------------------------------------- /opium/src/context.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Rock.Context 3 | 4 | let sexp_of_t m = 5 | let open Sexp in 6 | let l = 7 | fold 8 | (fun (B (k, v)) l -> 9 | let name, to_sexp = Key.info k in 10 | List [ Atom name; to_sexp v ] :: l) 11 | m 12 | [] 13 | in 14 | List l 15 | ;; 16 | 17 | let pp_hum fmt t = Sexp.pp_hum fmt (sexp_of_t t) 18 | 19 | let find_exn t k = 20 | match find t k with 21 | | None -> raise Not_found 22 | | Some s -> s 23 | ;; 24 | -------------------------------------------------------------------------------- /opium/src/context.mli: -------------------------------------------------------------------------------- 1 | (** A context holds heterogeneous value and is passed to the requests or responses. *) 2 | 3 | (** {2:keys Keys} *) 4 | 5 | (** The type for keys whose lookup value is of type ['a]. *) 6 | type 'a key = 'a Rock.Context.key 7 | 8 | (** {3 [Key]} *) 9 | 10 | module Key : sig 11 | (** {2:keys Keys} *) 12 | 13 | (** The type for key information. *) 14 | type 'a info = 'a Rock.Context.Key.info 15 | 16 | (** {3 [create]} *) 17 | 18 | (** [create i] is a new key with information [i]. *) 19 | val create : 'a info -> 'a key 20 | 21 | (** {3 [info]} *) 22 | 23 | (** [info k] is [k]'s information. *) 24 | val info : 'a key -> 'a info 25 | 26 | (** {2:exists Existential keys} 27 | 28 | Exisential keys allow to compare keys. This can be useful for functions like 29 | {!filter}. *) 30 | 31 | (** The type for existential keys. *) 32 | type t = Rock.Context.Key.t 33 | 34 | (** {3 [hide_type]} *) 35 | 36 | (** [hide_type k] is an existential key for [k]. *) 37 | val hide_type : 'a key -> t 38 | 39 | (** {3 [equal]} *) 40 | 41 | (** [equal k k'] is [true] iff [k] and [k'] are the same key. *) 42 | val equal : t -> t -> bool 43 | 44 | (** {3 [compare]} *) 45 | 46 | (** [compare k k'] is a total order on keys compatible with {!equal}. *) 47 | val compare : t -> t -> int 48 | end 49 | 50 | (** {2:maps Maps} *) 51 | 52 | (** The type for heterogeneous value maps. *) 53 | type t = Rock.Context.t 54 | 55 | (** {3 [empty]} *) 56 | 57 | (** [empty] is the empty map. *) 58 | val empty : t 59 | 60 | (** {3 [is_empty]} *) 61 | 62 | (** [is_empty m] is [true] iff [m] is empty. *) 63 | val is_empty : t -> bool 64 | 65 | (** {3 [mem]} *) 66 | 67 | (** [mem k m] is [true] iff [k] is bound in [m]. *) 68 | val mem : 'a key -> t -> bool 69 | 70 | (** {3 [add]} *) 71 | 72 | (** [add k v m] is [m] with [k] bound to [v]. *) 73 | val add : 'a key -> 'a -> t -> t 74 | 75 | (** {3 [singleton]} *) 76 | 77 | (** [singleton k v] is [add k v empty]. *) 78 | val singleton : 'a key -> 'a -> t 79 | 80 | (** {3 [rem]} *) 81 | 82 | (** [rem k m] is [m] with [k] unbound. *) 83 | val rem : 'a key -> t -> t 84 | 85 | (** {3 [find]} *) 86 | 87 | (** [find k m] is the value of [k]'s binding in [m], if any. *) 88 | val find : 'a key -> t -> 'a option 89 | 90 | (** {3 [find_exn]} *) 91 | 92 | (** [find_exn k m] is the value of [k]'s binding find_exn [m]. 93 | 94 | @raise Invalid_argument if [k] is not bound in [m]. *) 95 | val find_exn : 'a key -> t -> 'a 96 | 97 | (** {2:utilities Utilities} *) 98 | 99 | (** {3 [sexp_of_t]} *) 100 | 101 | (** [sexp_of_t t] converts the request [t] to an s-expression *) 102 | val sexp_of_t : t -> Sexplib0.Sexp.t 103 | 104 | (** {3 [pp_hum]} *) 105 | 106 | (** [pp_hum] formats the request [t] as a standard HTTP request *) 107 | val pp_hum : Format.formatter -> t -> unit 108 | [@@ocaml.toplevel_printer] 109 | -------------------------------------------------------------------------------- /opium/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name opium) 3 | (libraries rock cmdliner httpaf httpaf-lwt-unix logs logs.fmt mtime.clock.os 4 | ptime yojson tyxml digestif base64 astring re uri magic-mime 5 | multipart-form-data)) 6 | 7 | (include_subdirs unqualified) 8 | -------------------------------------------------------------------------------- /opium/src/handlers/handler_serve.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let respond_with_file ?headers read = 4 | let open Lwt.Syntax in 5 | let* body = read () in 6 | match body with 7 | | Error status -> 8 | let headers = Option.value headers ~default:Httpaf.Headers.empty in 9 | let resp = Response.make ~headers ~status:(status :> Httpaf.Status.t) () in 10 | Lwt.return resp 11 | | Ok body -> 12 | let headers = Option.value headers ~default:Httpaf.Headers.empty in 13 | let resp = Response.make ~headers ~status:`OK ~body () in 14 | Lwt.return resp 15 | ;; 16 | 17 | let h ?mime_type ?etag ?(headers = Httpaf.Headers.empty) read req = 18 | let etag_quoted = 19 | match etag with 20 | | Some etag -> Some (Printf.sprintf "%S" etag) 21 | | None -> None 22 | in 23 | let headers = 24 | match etag_quoted with 25 | | Some etag_quoted -> Httpaf.Headers.add_unless_exists headers "ETag" etag_quoted 26 | | None -> headers 27 | in 28 | let headers = 29 | match mime_type with 30 | | Some mime_type -> Httpaf.Headers.add_unless_exists headers "Content-Type" mime_type 31 | | None -> headers 32 | in 33 | let request_if_none_match = Httpaf.Headers.get req.Request.headers "If-None-Match" in 34 | let request_matches_etag = 35 | match request_if_none_match, etag_quoted with 36 | | Some request_etags, Some etag_quoted -> 37 | request_etags 38 | |> String.split_on_char ~sep:',' 39 | |> List.exists ~f:(fun request_etag -> String.trim request_etag = etag_quoted) 40 | | _ -> false 41 | in 42 | if request_matches_etag 43 | then Lwt.return @@ Response.make ~status:`Not_modified ~headers () 44 | else respond_with_file ~headers read 45 | ;; 46 | -------------------------------------------------------------------------------- /opium/src/handlers/handler_serve.mli: -------------------------------------------------------------------------------- 1 | val h 2 | : ?mime_type:string 3 | -> ?etag:string 4 | -> ?headers:Headers.t 5 | -> (unit -> (Body.t, [ Status.client_error | Status.server_error ]) Lwt_result.t) 6 | -> Rock.Handler.t 7 | -------------------------------------------------------------------------------- /opium/src/headers.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Httpaf.Headers 3 | 4 | let add_list_unless_exists t hs = 5 | List.fold_left hs ~init:t ~f:(fun acc (k, v) -> add_unless_exists acc k v) 6 | ;; 7 | 8 | let sexp_of_t headers = 9 | let open Sexp_conv in 10 | let sexp_of_header = sexp_of_list (sexp_of_pair sexp_of_string sexp_of_string) in 11 | sexp_of_header (to_list headers) 12 | ;; 13 | 14 | let pp fmt t = Sexp.pp_hum fmt (sexp_of_t t) 15 | let pp_hum fmt t = Format.fprintf fmt "%s" (to_string t) 16 | -------------------------------------------------------------------------------- /opium/src/import.ml: -------------------------------------------------------------------------------- 1 | include Sexplib0 2 | 3 | module List = struct 4 | include ListLabels 5 | 6 | let rec filter_opt = function 7 | | [] -> [] 8 | | None :: l -> filter_opt l 9 | | Some x :: l -> x :: filter_opt l 10 | ;; 11 | 12 | let rec find_map ~f = function 13 | | [] -> None 14 | | x :: l -> 15 | (match f x with 16 | | Some _ as result -> result 17 | | None -> find_map ~f l) 18 | ;; 19 | 20 | let replace_or_add ~f to_add l = 21 | let rec aux acc l found = 22 | match l with 23 | | [] -> rev (if not found then to_add :: acc else acc) 24 | | el :: rest -> 25 | if f el to_add then aux (to_add :: acc) rest true else aux (el :: acc) rest found 26 | in 27 | aux [] l false 28 | ;; 29 | 30 | let concat_map ~f l = 31 | let rec aux f acc = function 32 | | [] -> rev acc 33 | | x :: l -> 34 | let xs = f x in 35 | aux f (rev_append xs acc) l 36 | in 37 | aux f [] l 38 | ;; 39 | end 40 | 41 | module String = struct 42 | include StringLabels 43 | 44 | let rec check_prefix s ~prefix len i = 45 | i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1)) 46 | ;; 47 | 48 | let is_prefix s ~prefix = 49 | let len = length s in 50 | let prefix_len = length prefix in 51 | len >= prefix_len && check_prefix s ~prefix prefix_len 0 52 | ;; 53 | end 54 | -------------------------------------------------------------------------------- /opium/src/method.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Httpaf.Method 3 | 4 | let sexp_of_t meth = Sexp_conv.sexp_of_string (to_string meth) 5 | let pp fmt t = Sexp.pp_hum fmt (sexp_of_t t) 6 | -------------------------------------------------------------------------------- /opium/src/method.mli: -------------------------------------------------------------------------------- 1 | (* A major part of this documentation is extracted from 2 | {{:https://github.com/inhabitedtype/httpaf/blob/master/lib/httpaf.mli}. 3 | 4 | Copyright (c) 2016, Inhabited Type LLC 5 | 6 | All rights reserved.*) 7 | 8 | (** Request Method 9 | 10 | The request method token is the primary source of request semantics; it indicates the 11 | purpose for which the client has made this request and what is expected by the client 12 | as a successful result. 13 | 14 | See {{:https://tools.ietf.org/html/rfc7231#section-4} RFC7231§4} for more details. *) 15 | 16 | type standard = 17 | [ `GET 18 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.1} RFC7231§4.3.1}. Safe, 19 | Cacheable. *) 20 | | `HEAD 21 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.2} RFC7231§4.3.2}. Safe, 22 | Cacheable. *) 23 | | `POST 24 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.3} RFC7231§4.3.3}. Cacheable. 25 | *) 26 | | `PUT 27 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.4} RFC7231§4.3.4}. Idempotent. 28 | *) 29 | | `DELETE 30 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.5} RFC7231§4.3.5}. Idempotent. 31 | *) 32 | | `CONNECT (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.6} RFC7231§4.3.6}. *) 33 | | `OPTIONS 34 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.7} RFC7231§4.3.7}. Safe.*) 35 | | `TRACE 36 | (** {{:https://tools.ietf.org/html/rfc7231#section-4.3.8} RFC7231§4.3.8}. Safe.*) 37 | ] 38 | 39 | type t = 40 | [ standard 41 | | `Other of string (** Methods defined outside of RFC7231, or custom methods. *) 42 | ] 43 | 44 | (** Request methods are considered "safe" if their defined semantics are essentially 45 | read-only; i.e., the client does not request, and does not expect, any state change on 46 | the origin server as a result of applying a safe method to a target resource. 47 | Likewise, reasonable use of a safe method is not expected to cause any harm, loss of 48 | property, or unusual burden on the origin server. 49 | 50 | See {{:https://tools.ietf.org/html/rfc7231#section-4.2.1} RFC7231§4.2.1} for more 51 | details. *) 52 | val is_safe : standard -> bool 53 | 54 | (** Request methods can be defined as "cacheable" to indicate that responses to them are 55 | allowed to be stored for future reuse. 56 | 57 | See {{:https://tools.ietf.org/html/rfc7234} RFC7234} for more details. *) 58 | val is_cacheable : standard -> bool 59 | 60 | (** A request method is considered "idempotent" if the intended effect on the server of 61 | multiple identical requests with that method is the same as the effect for a single 62 | such request. Of the request methods defined by this specification, PUT, DELETE, and 63 | safe request methods are idempotent. 64 | 65 | See {{:https://tools.ietf.org/html/rfc7231#section-4.2.2} RFC7231§4.2.2} for more 66 | details. *) 67 | val is_idempotent : standard -> bool 68 | 69 | (** {2 Utilities} *) 70 | 71 | (** [to_string t] returns a string representation of the method [t]. *) 72 | val to_string : t -> string 73 | 74 | (** [of_string s] returns a method from its string representation [s]. *) 75 | val of_string : string -> t 76 | 77 | (** [sexp_of_t t] converts the request [t] to an s-expression *) 78 | val sexp_of_t : t -> Sexplib0.Sexp.t 79 | 80 | (** [pp] formats the request [t] as an s-expression *) 81 | val pp : Format.formatter -> t -> unit 82 | [@@ocaml.toplevel_printer] 83 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_allow_cors.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let default_origin = [ "*" ] 4 | let default_credentials = true 5 | let default_max_age = 1_728_000 6 | 7 | let default_headers = 8 | [ "Authorization" 9 | ; "Content-Type" 10 | ; "Accept" 11 | ; "Origin" 12 | ; "User-Agent" 13 | ; "DNT" 14 | ; "Cache-Control" 15 | ; "X-Mx-ReqToken" 16 | ; "Keep-Alive" 17 | ; "X-Requested-With" 18 | ; "If-Modified-Since" 19 | ; "X-CSRF-Token" 20 | ] 21 | ;; 22 | 23 | let default_expose = [] 24 | let default_methods = [ `GET; `POST; `PUT; `DELETE; `OPTIONS; `Other "PATCH" ] 25 | let default_send_preflight_response = true 26 | let request_origin request = Request.header "Origin" request 27 | 28 | let request_vary request = 29 | match Request.header "Vary" request with 30 | | None -> [] 31 | | Some s -> String.split_on_char ~sep:',' s 32 | ;; 33 | 34 | let allowed_origin origins request = 35 | let request_origin = request_origin request in 36 | match request_origin with 37 | | Some request_origin when List.exists ~f:(String.equal request_origin) origins -> 38 | Some request_origin 39 | | _ -> if List.exists ~f:(String.equal "*") origins then Some "*" else None 40 | ;; 41 | 42 | let vary_headers allowed_origin hs = 43 | let vary_header = request_vary hs in 44 | match allowed_origin, vary_header with 45 | | Some "*", _ -> [] 46 | | None, _ -> [] 47 | | _, [] -> [ "Vary", "Origin" ] 48 | | _, headers -> [ "Vary", "Origin" :: headers |> String.concat ~sep:"," ] 49 | ;; 50 | 51 | let cors_headers ~origins ~credentials ~expose request = 52 | let allowed_origin = allowed_origin origins request in 53 | let vary_headers = vary_headers allowed_origin request in 54 | [ "Access-Control-Allow-Origin", allowed_origin |> Option.value ~default:"" 55 | ; "Access-Control-Expose-Headers", String.concat ~sep:"," expose 56 | ; "Access-Control-Allow-Credentials", Bool.to_string credentials 57 | ] 58 | @ vary_headers 59 | ;; 60 | 61 | let allowed_headers ~headers request = 62 | let value = 63 | match headers with 64 | | [ "*" ] -> 65 | Request.header "Access-Control-Request-Headers" request |> Option.value ~default:"" 66 | | headers -> String.concat ~sep:"," headers 67 | in 68 | [ "Access-Control-Allow-Headers", value ] 69 | ;; 70 | 71 | let options_cors_headers ~max_age ~headers ~methods request = 72 | let methods = List.map methods ~f:Method.to_string in 73 | [ "Access-Control-Max-Age", string_of_int max_age 74 | ; "Access-Control-Allow-Methods", String.concat ~sep:"," methods 75 | ] 76 | @ allowed_headers ~headers request 77 | ;; 78 | 79 | let m 80 | ?(origins = default_origin) 81 | ?(credentials = default_credentials) 82 | ?(max_age = default_max_age) 83 | ?(headers = default_headers) 84 | ?(expose = default_expose) 85 | ?(methods = default_methods) 86 | ?(send_preflight_response = default_send_preflight_response) 87 | () 88 | = 89 | let open Lwt.Syntax in 90 | let filter handler req = 91 | let+ response = handler req in 92 | let hs = cors_headers ~origins ~credentials ~expose req in 93 | let hs = 94 | if req.Request.meth = `OPTIONS 95 | then hs @ options_cors_headers ~max_age ~headers ~methods req 96 | else hs 97 | in 98 | match send_preflight_response, req.Request.meth with 99 | | true, `OPTIONS -> Response.make ~status:`No_content ~headers:(Headers.of_list hs) () 100 | | _ -> 101 | { response with 102 | headers = Headers.add_list response.Response.headers (hs |> List.rev) 103 | } 104 | in 105 | Rock.Middleware.create ~name:"Allow CORS" ~filter 106 | ;; 107 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_allow_cors.mli: -------------------------------------------------------------------------------- 1 | val m 2 | : ?origins:String.t list 3 | -> ?credentials:bool 4 | -> ?max_age:int 5 | -> ?headers:string list 6 | -> ?expose:string list 7 | -> ?methods:Method.t list 8 | -> ?send_preflight_response:bool 9 | -> unit 10 | -> Rock.Middleware.t 11 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_basic_auth.ml: -------------------------------------------------------------------------------- 1 | let m ?unauthorized_handler ~key ~realm ~auth_callback () = 2 | let unauthorized_handler = 3 | Option.value unauthorized_handler ~default:(fun _req -> 4 | Response.of_plain_text "Forbidden access" ~status:`Unauthorized 5 | |> Response.add_header ("WWW-Authenticate", Auth.string_of_challenge (Basic realm)) 6 | |> Lwt.return) 7 | in 8 | let filter handler ({ Request.env; _ } as req) = 9 | let open Lwt.Syntax in 10 | let+ resp = 11 | match Request.authorization req with 12 | | None -> unauthorized_handler req 13 | | Some (Other _) -> unauthorized_handler req 14 | | Some (Basic (username, password)) -> 15 | let* user_opt = auth_callback ~username ~password in 16 | (match user_opt with 17 | | None -> unauthorized_handler req 18 | | Some user -> 19 | let env = Context.add key user env in 20 | let req = { req with Request.env } in 21 | handler req) 22 | in 23 | match resp.Response.status with 24 | | `Unauthorized -> 25 | Response.add_header 26 | ("WWW-Authenticate", Auth.string_of_challenge (Basic realm)) 27 | resp 28 | | _ -> resp 29 | in 30 | Rock.Middleware.create ~name:"Basic authentication" ~filter 31 | ;; 32 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_basic_auth.mli: -------------------------------------------------------------------------------- 1 | val m 2 | : ?unauthorized_handler:Rock.Handler.t 3 | -> key:'a Context.key 4 | -> realm:string 5 | -> auth_callback:(username:string -> password:string -> 'a option Lwt.t) 6 | -> unit 7 | -> Rock.Middleware.t 8 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_content_length.ml: -------------------------------------------------------------------------------- 1 | let m = 2 | let open Lwt.Syntax in 3 | let filter handler req = 4 | let+ res = handler req in 5 | let length = Body.length res.Response.body in 6 | match length with 7 | | None -> 8 | res 9 | |> Response.remove_header "Content-Length" 10 | |> Response.add_header_unless_exists ("Transfer-Encoding", "chunked") 11 | | Some l -> Response.add_header_or_replace ("Content-Length", Int64.to_string l) res 12 | in 13 | Rock.Middleware.create ~name:"Content length" ~filter 14 | ;; 15 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_content_length.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_debugger.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_etag.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | (* TODO: The non-cached responses should include Cache-Control, Content-Location, Date, 4 | ETag, Expires, and Vary *) 5 | 6 | let etag_of_body body = 7 | let encode s = 8 | let open Digestif.MD5 in 9 | s |> digest_string |> to_raw_string |> Base64.encode_exn 10 | in 11 | match body.Body.content with 12 | | `String s -> Some (encode s) 13 | | `Bigstring b -> Some (b |> Bigstringaf.to_string |> encode) 14 | | `Empty -> Some (encode "") 15 | | `Stream _ -> None 16 | ;; 17 | 18 | let m = 19 | let filter handler req = 20 | let open Lwt.Syntax in 21 | let* response = handler req in 22 | match response.Response.status with 23 | | `OK | `Created | `Accepted -> 24 | let etag_quoted = 25 | match etag_of_body response.Response.body with 26 | | Some etag -> Some (Printf.sprintf "%S" etag) 27 | | None -> None 28 | in 29 | let response = 30 | match etag_quoted with 31 | | Some etag_quoted -> 32 | Response.add_header_or_replace ("ETag", etag_quoted) response 33 | | None -> response 34 | in 35 | let request_if_none_match = Response.header "If-None-Match" response in 36 | let request_matches_etag = 37 | match request_if_none_match, etag_quoted with 38 | | Some request_etags, Some etag_quoted -> 39 | request_etags 40 | |> String.split_on_char ~sep:',' 41 | |> List.exists ~f:(fun request_etag -> String.trim request_etag = etag_quoted) 42 | | _ -> false 43 | in 44 | if request_matches_etag 45 | then Lwt.return @@ Response.make ~status:`Not_modified ~headers:response.headers () 46 | else Lwt.return response 47 | | _ -> Lwt.return response 48 | in 49 | Rock.Middleware.create ~name:"ETag" ~filter 50 | ;; 51 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_etag.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_head.ml: -------------------------------------------------------------------------------- 1 | (* The implementation of this middleware is based on Finagle's HeadFilter 2 | https://github.com/twitter/finagle/blob/develop/finagle-http/src/main/scala/com/twitter/finagle/http/filter/HeadFilter.scala 3 | 4 | It has to be before {!Middleware_content_length} *) 5 | 6 | let m = 7 | let open Lwt.Syntax in 8 | let filter handler req = 9 | let req = 10 | match req.Request.meth with 11 | | `HEAD -> { req with meth = `GET } 12 | | _ -> req 13 | in 14 | let* response = handler req in 15 | let body_length = Body.length response.Response.body in 16 | let response = 17 | match body_length with 18 | | Some l -> 19 | { response with body = Body.empty } 20 | |> Response.add_header_or_replace ("Content-Length", Int64.to_string l) 21 | |> Response.remove_header "Content-Encoding" 22 | | None -> 23 | { response with body = Body.empty } 24 | |> Response.remove_header "Content-Length" 25 | |> Response.remove_header "Content-Encoding" 26 | in 27 | Lwt.return response 28 | in 29 | Rock.Middleware.create ~name:"Head" ~filter 30 | ;; 31 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_head.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_logger.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let log_src = Logs.Src.create "opium.server" 4 | 5 | module Log = (val Logs.src_log log_src : Logs.LOG) 6 | 7 | let body_to_string ?(content_type = "text/plain") ?(max_len = 1000) body = 8 | let open Lwt.Syntax in 9 | let lhs, rhs = 10 | match String.split_on_char ~sep:'/' content_type with 11 | | [ lhs; rhs ] -> lhs, rhs 12 | | _ -> "application", "octet-stream" 13 | in 14 | match lhs, rhs with 15 | | "text", _ | "application", "json" | "application", "x-www-form-urlencoded" -> 16 | let+ s = Body.copy body |> Body.to_string in 17 | if String.length s > max_len 18 | then 19 | String.sub s ~pos:0 ~len:(min (String.length s) max_len) 20 | ^ Format.asprintf " [truncated %d characters]" (String.length s - max_len) 21 | else s 22 | | _ -> Lwt.return ("<" ^ content_type ^ ">") 23 | ;; 24 | 25 | let request_to_string (request : Request.t) = 26 | let open Lwt.Syntax in 27 | let content_type = Request.content_type request in 28 | let+ body_string = body_to_string ?content_type request.body in 29 | Format.asprintf 30 | "%s %s %s\n%s\n\n%s\n%!" 31 | (Method.to_string request.meth) 32 | request.target 33 | (Version.to_string request.version) 34 | (Headers.to_string request.headers) 35 | body_string 36 | ;; 37 | 38 | let response_to_string (response : Response.t) = 39 | let open Lwt.Syntax in 40 | let content_type = Response.content_type response in 41 | let+ body_string = body_to_string ?content_type response.body in 42 | Format.asprintf 43 | "%a %a %s\n%a\n%s\n%!" 44 | Version.pp_hum 45 | response.version 46 | Status.pp_hum 47 | response.status 48 | (Option.value ~default:"" response.reason) 49 | Headers.pp_hum 50 | response.headers 51 | body_string 52 | ;; 53 | 54 | let respond handler req = 55 | let time_f f = 56 | let t1 = Mtime_clock.now () in 57 | let x = f () in 58 | let t2 = Mtime_clock.now () in 59 | let span = Mtime.span t1 t2 in 60 | span, x 61 | in 62 | let open Lwt.Syntax in 63 | let f () = handler req in 64 | let span, response_lwt = time_f f in 65 | let* response = response_lwt in 66 | let code = response.Response.status |> Status.to_string in 67 | Log.info (fun m -> m "Responded with HTTP code %s in %a" code Mtime.Span.pp span); 68 | let+ response_string = response_to_string response in 69 | Log.debug (fun m -> m "%s" response_string); 70 | response 71 | ;; 72 | 73 | let m = 74 | let open Lwt.Syntax in 75 | let filter handler req = 76 | let meth = Method.to_string req.Request.meth in 77 | let uri = req.Request.target |> Uri.of_string |> Uri.path_and_query in 78 | Logs.info ~src:log_src (fun m -> m "Received %s %S" meth uri); 79 | let* request_string = request_to_string req in 80 | Logs.debug ~src:log_src (fun m -> m "%s" request_string); 81 | Lwt.catch 82 | (fun () -> respond handler req) 83 | (fun exn -> 84 | Logs.err ~src:log_src (fun f -> f "%s" (Nifty.Exn.to_string exn)); 85 | Lwt.fail exn) 86 | in 87 | Rock.Middleware.create ~name:"Logger" ~filter 88 | ;; 89 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_logger.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | val request_to_string : Request.t -> string Lwt.t 3 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_method_override.ml: -------------------------------------------------------------------------------- 1 | let m = 2 | let open Lwt.Syntax in 3 | let filter handler req = 4 | let content_type = Request.content_type req in 5 | match req.Request.meth, content_type with 6 | | `POST, Some "application/x-www-form-urlencoded" -> 7 | let* method_result = 8 | Request.urlencoded "_method" req 9 | |> Lwt.map (fun el -> Option.map String.uppercase_ascii el) 10 | in 11 | let method_ = 12 | match method_result with 13 | | Some m -> 14 | (match Method.of_string m with 15 | | (`PUT | `DELETE | `Other "PATCH") as m -> m 16 | | _ -> req.meth) 17 | | None -> req.meth 18 | in 19 | handler { req with meth = method_ } 20 | | _ -> handler req 21 | in 22 | Rock.Middleware.create ~name:"Method override" ~filter 23 | ;; 24 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_method_override.mli: -------------------------------------------------------------------------------- 1 | val m : Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_method_required.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let allowed_methods = [ `GET; `HEAD; `POST ] 4 | 5 | let m ?(allowed_methods = allowed_methods) () = 6 | let filter handler req = 7 | match List.mem req.Request.meth ~set:allowed_methods with 8 | | true -> handler req 9 | | false -> Lwt.return (Response.make ~status:`Method_not_allowed ()) 10 | in 11 | Rock.Middleware.create ~name:"Method required" ~filter 12 | ;; 13 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_method_required.mli: -------------------------------------------------------------------------------- 1 | val m : ?allowed_methods:Method.t list -> unit -> Rock.Middleware.t 2 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_router.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | module Method_map = Map.Make (struct 4 | type t = Method.t 5 | 6 | let compare a b = 7 | let left = String.uppercase_ascii (Method.to_string a) in 8 | let right = String.uppercase_ascii (Method.to_string b) in 9 | String.compare left right 10 | ;; 11 | end) 12 | 13 | type 'a t = (Route.t * 'a) list Method_map.t 14 | 15 | let empty = Method_map.empty 16 | 17 | let get t meth = 18 | match Method_map.find_opt meth t with 19 | | None -> [] 20 | | Some xs -> List.rev xs 21 | ;; 22 | 23 | let add t ~route ~meth ~action = 24 | Method_map.update 25 | meth 26 | (function 27 | | None -> Some [ route, action ] 28 | | Some xs -> Some ((route, action) :: xs)) 29 | t 30 | ;; 31 | 32 | (** finds matching endpoint and returns it with the parsed list of parameters *) 33 | let matching_endpoint endpoints meth uri = 34 | let endpoints = get endpoints meth in 35 | List.find_map endpoints ~f:(fun ep -> 36 | uri |> Route.match_url (fst ep) |> Option.map (fun p -> ep, p)) 37 | ;; 38 | 39 | module Env = struct 40 | let key : Route.matches Context.key = 41 | Context.Key.create ("path_params", Route.sexp_of_matches) 42 | ;; 43 | end 44 | 45 | let splat req = Context.find_exn Env.key req.Request.env |> fun route -> route.Route.splat 46 | 47 | (* not param_exn since if the endpoint was selected it's likely that the parameter is 48 | already there *) 49 | let param req param = 50 | let { Route.params; _ } = Context.find_exn Env.key req.Request.env in 51 | List.assoc param params 52 | ;; 53 | 54 | let m endpoints = 55 | let filter default req = 56 | match matching_endpoint endpoints req.Request.meth req.Request.target with 57 | | None -> default req 58 | | Some (endpoint, params) -> 59 | let env_with_params = Context.add Env.key params req.Request.env in 60 | (snd endpoint) { req with Request.env = env_with_params } 61 | in 62 | Rock.Middleware.create ~name:"Router" ~filter 63 | ;; 64 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_router.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val m : Rock.Handler.t t -> Rock.Middleware.t 4 | val empty : 'action t 5 | val add : 'a t -> route:Route.t -> meth:Method.t -> action:'a -> 'a t 6 | val param : Request.t -> string -> string 7 | val splat : Request.t -> string list 8 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_static.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | let log_src = 4 | Logs.Src.create ~doc:"Opium middleware to server static files" "opium.static_server" 5 | ;; 6 | 7 | module Log = (val Logs.src_log log_src : Logs.LOG) 8 | 9 | let is_prefix ~prefix s = 10 | String.length prefix <= String.length s 11 | && 12 | let i = ref 0 in 13 | while !i < String.length prefix && s.[!i] = prefix.[!i] do 14 | incr i 15 | done; 16 | !i = String.length prefix 17 | ;; 18 | 19 | let chop_prefix ~prefix s = 20 | assert (is_prefix ~prefix s); 21 | String.sub s ~pos:(String.length prefix) ~len:String.(length s - length prefix) 22 | ;; 23 | 24 | let _add_opt_header_unless_exists headers k v = 25 | match headers with 26 | | Some h -> Httpaf.Headers.add_unless_exists h k v 27 | | None -> Httpaf.Headers.of_list [ k, v ] 28 | ;; 29 | 30 | let m ~read ?(uri_prefix = "/") ?headers ?etag_of_fname () = 31 | let open Lwt.Syntax in 32 | let filter handler req = 33 | if req.Request.meth = `GET 34 | then ( 35 | let local_path = req.target in 36 | if local_path |> is_prefix ~prefix:uri_prefix 37 | then ( 38 | let legal_path = chop_prefix local_path ~prefix:uri_prefix in 39 | let read () = read legal_path in 40 | let mime_type = Magic_mime.lookup legal_path in 41 | let* etag = 42 | match etag_of_fname with 43 | | Some f -> f legal_path 44 | | None -> Lwt.return None 45 | in 46 | let* res = Handler_serve.h read ~mime_type ?etag ?headers req in 47 | match res.status with 48 | | `Not_found -> handler req 49 | | _ -> Lwt.return res) 50 | else handler req) 51 | else handler req 52 | in 53 | Rock.Middleware.create ~name:"Static" ~filter 54 | ;; 55 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_static.mli: -------------------------------------------------------------------------------- 1 | val m 2 | : read:(string -> (Body.t, [ Status.client_error | Status.server_error ]) Lwt_result.t) 3 | -> ?uri_prefix:string 4 | -> ?headers:Headers.t 5 | -> ?etag_of_fname:(string -> string option Lwt.t) 6 | -> unit 7 | -> Rock.Middleware.t 8 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_static_unix.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | let default_etag ~local_path fname = 4 | let fpath = Filename.concat local_path fname in 5 | let* exists = Lwt_unix.file_exists fpath in 6 | if exists 7 | then 8 | let* stat = Lwt_unix.stat fpath in 9 | let hash = 10 | Marshal.to_string stat.st_mtime [] 11 | |> Digestif.MD5.digest_string 12 | |> Digestif.MD5.to_raw_string 13 | |> Base64.encode_exn 14 | in 15 | Lwt.return_some hash 16 | else Lwt.return_none 17 | ;; 18 | 19 | let m ~local_path ?uri_prefix ?headers ?(etag_of_fname = default_etag ~local_path) () = 20 | let read fname = 21 | let* body = Body.of_file (Filename.concat local_path fname) in 22 | match body with 23 | | None -> Lwt.return (Error `Not_found) 24 | | Some body -> Lwt.return (Ok body) 25 | in 26 | Middleware_static.m ~read ?uri_prefix ?headers ~etag_of_fname () 27 | ;; 28 | -------------------------------------------------------------------------------- /opium/src/middlewares/middleware_static_unix.mli: -------------------------------------------------------------------------------- 1 | val m 2 | : local_path:string 3 | -> ?uri_prefix:string 4 | -> ?headers:Headers.t 5 | -> ?etag_of_fname:(string -> string option Lwt.t) 6 | -> unit 7 | -> Rock.Middleware.t 8 | -------------------------------------------------------------------------------- /opium/src/nifty.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | module Exn = struct 4 | type t = exn 5 | 6 | let sexp_of_t = Sexp_conv.sexp_of_exn 7 | let pp fmt t = Sexp.pp fmt t 8 | let to_string t = Printexc.to_string t 9 | end 10 | -------------------------------------------------------------------------------- /opium/src/opium.ml: -------------------------------------------------------------------------------- 1 | module Context = Context 2 | module Headers = Headers 3 | module Cookie = Cookie 4 | module Method = Method 5 | module Version = Version 6 | module Status = Status 7 | module Body = Body 8 | module Request = Request 9 | module Response = Response 10 | module App = App 11 | module Route = Route 12 | module Auth = Auth 13 | module Router = Middleware_router 14 | 15 | module Handler = struct 16 | let serve = Handler_serve.h 17 | end 18 | 19 | module Middleware = struct 20 | let router = Middleware_router.m 21 | let debugger = Middleware_debugger.m 22 | let logger = Middleware_logger.m 23 | let allow_cors = Middleware_allow_cors.m 24 | let static = Middleware_static.m 25 | let static_unix = Middleware_static_unix.m 26 | let content_length = Middleware_content_length.m 27 | let method_override = Middleware_method_override.m 28 | let etag = Middleware_etag.m 29 | let method_required = Middleware_method_required.m 30 | let head = Middleware_head.m 31 | let basic_auth = Middleware_basic_auth.m 32 | end 33 | -------------------------------------------------------------------------------- /opium/src/request.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Rock.Request 3 | 4 | let of_string' 5 | ?(content_type = "text/plain") 6 | ?version 7 | ?env 8 | ?(headers = Headers.empty) 9 | target 10 | meth 11 | body 12 | = 13 | let headers = Headers.add_unless_exists headers "Content-Type" content_type in 14 | make ?version ~headers ~body:(Body.of_string body) ?env target meth 15 | ;; 16 | 17 | let of_plain_text ?version ?headers ?env ~body target meth = 18 | of_string' ?version ?env ?headers target meth body 19 | ;; 20 | 21 | let of_json ?version ?headers ?env ~body target meth = 22 | of_string' 23 | ~content_type:"application/json" 24 | ?version 25 | ?headers 26 | ?env 27 | target 28 | meth 29 | (body |> Yojson.Safe.to_string) 30 | ;; 31 | 32 | let of_urlencoded ?version ?headers ?env ~body target meth = 33 | of_string' 34 | ~content_type:"application/x-www-form-urlencoded" 35 | ?version 36 | ?headers 37 | ?env 38 | target 39 | meth 40 | (body |> Uri.encoded_of_query) 41 | ;; 42 | 43 | let to_json_exn t = 44 | let open Lwt.Syntax in 45 | let* body = t.body |> Body.copy |> Body.to_string in 46 | Lwt.return @@ Yojson.Safe.from_string body 47 | ;; 48 | 49 | let to_json t = 50 | let open Lwt.Syntax in 51 | Lwt.catch 52 | (fun () -> 53 | let+ json = to_json_exn t in 54 | Some json) 55 | (function _ -> Lwt.return None) 56 | ;; 57 | 58 | let to_plain_text t = Body.copy t.body |> Body.to_string 59 | 60 | let to_urlencoded t = 61 | let open Lwt.Syntax in 62 | let* body = t.body |> Body.copy |> Body.to_string in 63 | body |> Uri.query_of_encoded |> Lwt.return 64 | ;; 65 | 66 | let header header t = Headers.get t.headers header 67 | let headers header t = Headers.get_multi t.headers header 68 | let add_header (k, v) t = { t with headers = Headers.add t.headers k v } 69 | 70 | let add_header_or_replace (k, v) t = 71 | { t with 72 | headers = 73 | (if Headers.mem t.headers k 74 | then Headers.replace t.headers k v 75 | else Headers.add t.headers k v) 76 | } 77 | ;; 78 | 79 | let add_header_unless_exists (k, v) t = 80 | { t with headers = Headers.add_unless_exists t.headers k v } 81 | ;; 82 | 83 | let add_headers hs t = { t with headers = Headers.add_list t.headers hs } 84 | 85 | let add_headers_or_replace hs t = 86 | List.fold_left hs ~init:t ~f:(fun acc el -> add_header_or_replace el acc) 87 | ;; 88 | 89 | let add_headers_unless_exists hs t = 90 | { t with headers = Headers.add_list_unless_exists t.headers hs } 91 | ;; 92 | 93 | let remove_header key t = { t with headers = Headers.remove t.headers key } 94 | 95 | let cookie ?signed_with cookie t = 96 | Cookie.cookie_of_headers ?signed_with cookie (t.headers |> Headers.to_list) 97 | |> Option.map snd 98 | ;; 99 | 100 | let cookies ?signed_with t = 101 | Cookie.cookies_of_headers ?signed_with (t.headers |> Headers.to_list) 102 | ;; 103 | 104 | let add_cookie ?sign_with (k, v) t = 105 | let cookies = cookies t in 106 | let cookies = 107 | List.replace_or_add 108 | ~f:(fun (k2, _v2) _ -> String.equal k k2) 109 | ( k 110 | , match sign_with with 111 | | Some signer -> Cookie.Signer.sign signer v 112 | | None -> v ) 113 | cookies 114 | in 115 | let cookie_header = cookies |> List.map ~f:Cookie.make |> Cookie.to_cookie_header in 116 | add_header_or_replace cookie_header t 117 | ;; 118 | 119 | let add_cookie_unless_exists ?sign_with (k, v) t = 120 | let cookies = cookies t in 121 | if List.exists cookies ~f:(fun (k2, _v2) -> String.equal k2 k) 122 | then t 123 | else add_cookie ?sign_with (k, v) t 124 | ;; 125 | 126 | let remove_cookie key t = 127 | let cookie_header = 128 | cookies t 129 | |> List.filter_map ~f:(fun (k, v) -> 130 | if not (String.equal k key) then Some (Cookie.make (k, v)) else None) 131 | |> Cookie.to_cookie_header 132 | in 133 | add_header_or_replace cookie_header t 134 | ;; 135 | 136 | let content_type t = header "Content-Type" t 137 | let set_content_type s t = add_header ("Content-Type", s) t 138 | 139 | let authorization t = 140 | let s = header "Authorization" t in 141 | Option.map Auth.credential_of_string s 142 | ;; 143 | 144 | let set_authorization cred t = 145 | let s = Auth.string_of_credential cred in 146 | add_header ("Authorization", s) t 147 | ;; 148 | 149 | let to_multipart_form_data 150 | ?(callback = fun ~name:_ ~filename:_ _line -> Lwt.return_unit) 151 | t 152 | = 153 | match t.meth, content_type t with 154 | | `POST, Some content_type 155 | when String.is_prefix content_type ~prefix:"multipart/form-data; boundary=" -> 156 | let open Lwt.Syntax in 157 | let body = t.body |> Body.copy |> Body.to_stream in 158 | let* result = Multipart_form_data.parse ~stream:body ~content_type ~callback in 159 | Lwt.return @@ Some result 160 | | _ -> Lwt.return None 161 | ;; 162 | 163 | let to_multipart_form_data_exn ?callback t = 164 | let open Lwt.Syntax in 165 | let* result = to_multipart_form_data ?callback t in 166 | match result with 167 | | Some r -> Lwt.return r 168 | | None -> 169 | raise (Invalid_argument "The request is not a valid multipart/form-data request.") 170 | ;; 171 | 172 | let find_in_query key query = 173 | query 174 | |> List.assoc_opt key 175 | |> fun opt -> 176 | Option.bind opt (function 177 | | [] -> None 178 | | x :: _ -> Some x) 179 | ;; 180 | 181 | let find_list_in_query key query = 182 | query |> List.concat_map ~f:(fun (k, v) -> if k = key then v else []) 183 | ;; 184 | 185 | let urlencoded key t = 186 | let open Lwt.Syntax in 187 | let* query = to_urlencoded t in 188 | Lwt.return @@ find_in_query key query 189 | ;; 190 | 191 | let urlencoded_list key t = 192 | let open Lwt.Syntax in 193 | let* query = to_urlencoded t in 194 | Lwt.return @@ find_list_in_query key query 195 | ;; 196 | 197 | let urlencoded_exn key t = 198 | let open Lwt.Syntax in 199 | let+ o = urlencoded key t in 200 | Option.get o 201 | ;; 202 | 203 | let query_list t = t.target |> Uri.of_string |> Uri.query 204 | let query key t = query_list t |> find_in_query key 205 | let query_exn key t = query key t |> Option.get 206 | 207 | let sexp_of_t { version; target; headers; meth; body; env } = 208 | let open Sexp_conv in 209 | let open Sexp in 210 | List 211 | [ List [ Atom "version"; Version.sexp_of_t version ] 212 | ; List [ Atom "target"; sexp_of_string target ] 213 | ; List [ Atom "method"; Method.sexp_of_t meth ] 214 | ; List [ Atom "headers"; Headers.sexp_of_t headers ] 215 | ; List [ Atom "body"; Body.sexp_of_t body ] 216 | ; List [ Atom "env"; Context.sexp_of_t env ] 217 | ] 218 | ;; 219 | 220 | let pp fmt t = Sexplib0.Sexp.pp_hum fmt (sexp_of_t t) 221 | 222 | let pp_hum fmt t = 223 | Format.fprintf 224 | fmt 225 | "%s %s %s\n%s\n\n%a\n%!" 226 | (Method.to_string t.meth) 227 | t.target 228 | (Version.to_string t.version) 229 | (Headers.to_string t.headers) 230 | Body.pp_hum 231 | t.body 232 | ;; 233 | -------------------------------------------------------------------------------- /opium/src/route.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | 3 | type path_segment = 4 | | Match of string 5 | | Param of string 6 | | Splat 7 | | FullSplat 8 | | Slash 9 | 10 | type matches = 11 | { params : (string * string) list 12 | ; splat : string list 13 | } 14 | 15 | let sexp_of_matches { params; splat } = 16 | let splat' = Sexp_conv.sexp_of_list Sexp_conv.sexp_of_string splat in 17 | let sexp_of_param (a, b) = Sexp_conv.sexp_of_list Sexp_conv.sexp_of_string [ a; b ] in 18 | Sexp.List 19 | [ List [ Atom "params"; Sexp_conv.sexp_of_list sexp_of_param params ] 20 | ; List [ Atom "splat"; splat' ] 21 | ] 22 | ;; 23 | 24 | type t = path_segment list 25 | 26 | let parse_param s = 27 | if s = "/" 28 | then Slash 29 | else if s = "*" 30 | then Splat 31 | else if s = "**" 32 | then FullSplat 33 | else ( 34 | try Scanf.sscanf s ":%s" (fun s -> Param s) with 35 | | Scanf.Scan_failure _ -> Match s) 36 | ;; 37 | 38 | let of_list l = 39 | let last_i = List.length l - 1 in 40 | l 41 | |> List.mapi ~f:(fun i s -> 42 | match parse_param s with 43 | | FullSplat when i <> last_i -> invalid_arg "** is only allowed at the end" 44 | | x -> x) 45 | ;; 46 | 47 | let split_slash_delim = 48 | let re = '/' |> Re.char |> Re.compile in 49 | fun path -> 50 | path 51 | |> Re.split_full re 52 | |> List.map ~f:(function 53 | | `Text s -> `Text s 54 | | `Delim _ -> `Delim) 55 | ;; 56 | 57 | let split_slash path = 58 | path 59 | |> split_slash_delim 60 | |> List.map ~f:(function 61 | | `Text s -> s 62 | | `Delim -> "/") 63 | ;; 64 | 65 | let of_string path = path |> split_slash |> of_list 66 | 67 | let to_string l = 68 | let r = 69 | l 70 | |> List.filter_map ~f:(function 71 | | Match s -> Some s 72 | | Param s -> Some (":" ^ s) 73 | | Splat -> Some "*" 74 | | FullSplat -> Some "**" 75 | | Slash -> None) 76 | |> String.concat ~sep:"/" 77 | in 78 | "/" ^ r 79 | ;; 80 | 81 | let rec match_url t url ({ params; splat } as matches) = 82 | match t, url with 83 | | [], [] -> Some { matches with splat = List.rev splat } 84 | | [ FullSplat ], rest -> 85 | let splat' = 86 | List.filter_map 87 | ~f:(function 88 | | `Delim -> None 89 | | `Text s -> Some (Uri.pct_decode s)) 90 | rest 91 | in 92 | Some { matches with splat = splat' @ List.rev splat } 93 | | FullSplat :: _, _ -> assert false (* splat can only be last *) 94 | | Match x :: t, `Text y :: url when x = y -> match_url t url matches 95 | | Slash :: t, `Delim :: url -> match_url t url matches 96 | | Splat :: t, `Text s :: url -> 97 | match_url t url { matches with splat = Uri.pct_decode s :: splat } 98 | | Param name :: t, `Text p :: url -> 99 | match_url t url { matches with params = (name, Uri.pct_decode p) :: params } 100 | | Splat :: _, `Delim :: _ 101 | | Param _ :: _, `Delim :: _ 102 | | Match _ :: _, _ 103 | | Slash :: _, _ 104 | | _ :: _, [] 105 | | [], _ :: _ -> None 106 | ;; 107 | 108 | let match_url t url = 109 | let path = 110 | match String.index_opt url '?' with 111 | | None -> url 112 | | Some i -> String.sub url ~pos:0 ~len:i 113 | in 114 | let path = path |> split_slash_delim in 115 | match_url t path { params = []; splat = [] } 116 | ;; 117 | -------------------------------------------------------------------------------- /opium/src/route.mli: -------------------------------------------------------------------------------- 1 | (** Expression that represent a target or multiple *) 2 | 3 | type t 4 | 5 | type matches = 6 | { params : (string * string) list 7 | ; splat : string list 8 | } 9 | 10 | (** [sexp_of_t matches] converts the matches [matches] to an s-expression *) 11 | val sexp_of_matches : matches -> Sexplib0.Sexp.t 12 | 13 | (** [of_string s] returns a route from its string representation [s]. *) 14 | val of_string : string -> t 15 | 16 | (** [to_string t] returns a string representation of the route [t]. *) 17 | val to_string : t -> string 18 | 19 | (** [match_url t url] return the matches of the url [url] for the route [t], or [None] if 20 | the url does not match. *) 21 | val match_url : t -> string -> matches option 22 | -------------------------------------------------------------------------------- /opium/src/status.mli: -------------------------------------------------------------------------------- 1 | (* A major part of this documentation is extracted from 2 | {{:https://github.com/inhabitedtype/httpaf/blob/master/lib/httpaf.mli}. 3 | 4 | Copyright (c) 2016, Inhabited Type LLC 5 | 6 | All rights reserved.*) 7 | 8 | (** Response Status Codes 9 | 10 | The status-code element is a three-digit integer code giving the result of the attempt 11 | to understand and satisfy the request. 12 | 13 | See {{:https://tools.ietf.org/html/rfc7231#section-6} RFC7231§6} for more details. *) 14 | 15 | (** The 1xx (Informational) class of status code indicates an interim response for 16 | communicating connection status or request progress prior to completing the requested 17 | action and sending a final response. See 18 | {{:https://tools.ietf.org/html/rfc7231#section-6.2} RFC7231§6.2} for more details. *) 19 | type informational = 20 | [ `Continue 21 | | `Switching_protocols 22 | ] 23 | 24 | (** The 2xx (Successful) class of status code indicates that the client's request was 25 | successfully received, understood, and accepted. See 26 | {{:https://tools.ietf.org/html/rfc7231#section-6.3} RFC7231§6.3} for more details. *) 27 | type successful = 28 | [ `OK 29 | | `Created 30 | | `Accepted 31 | | `Non_authoritative_information 32 | | `No_content 33 | | `Reset_content 34 | | `Partial_content 35 | ] 36 | 37 | (** The 3xx (Redirection) class of status code indicates that further action needs to be 38 | taken by the user agent in order to fulfill the request. See 39 | {{:https://tools.ietf.org/html/rfc7231#section-6.4} RFC7231§6.4} for more details. *) 40 | type redirection = 41 | [ `Multiple_choices 42 | | `Moved_permanently 43 | | `Found 44 | | `See_other 45 | | `Not_modified 46 | | `Use_proxy 47 | | `Temporary_redirect 48 | ] 49 | 50 | (** The 4xx (Client Error) class of status code indicates that the client seems to have 51 | erred. See {{:https://tools.ietf.org/html/rfc7231#section-6.5} RFC7231§6.5} for more 52 | details. *) 53 | type client_error = 54 | [ `Bad_request 55 | | `Unauthorized 56 | | `Payment_required 57 | | `Forbidden 58 | | `Not_found 59 | | `Method_not_allowed 60 | | `Not_acceptable 61 | | `Proxy_authentication_required 62 | | `Request_timeout 63 | | `Conflict 64 | | `Gone 65 | | `Length_required 66 | | `Precondition_failed 67 | | `Payload_too_large 68 | | `Uri_too_long 69 | | `Unsupported_media_type 70 | | `Range_not_satisfiable 71 | | `Expectation_failed 72 | | `Upgrade_required 73 | | `I_m_a_teapot 74 | | `Enhance_your_calm 75 | ] 76 | 77 | (** The 5xx (Server Error) class of status code indicates that the server is aware that it 78 | has erred or is incapable of performing the requested method. See 79 | {{:https://tools.ietf.org/html/rfc7231#section-6.6} RFC7231§6.6} for more details. *) 80 | type server_error = 81 | [ `Internal_server_error 82 | | `Not_implemented 83 | | `Bad_gateway 84 | | `Service_unavailable 85 | | `Gateway_timeout 86 | | `Http_version_not_supported 87 | ] 88 | 89 | (** The status codes defined in the HTTP 1.1 RFCs *) 90 | type standard = 91 | [ informational 92 | | successful 93 | | redirection 94 | | client_error 95 | | server_error 96 | ] 97 | 98 | (** The standard codes along with support for custom codes. *) 99 | type t = 100 | [ standard 101 | | `Code of int 102 | ] 103 | 104 | (** [default_reason_phrase standard] is the example reason phrase provided by RFC7231 for 105 | the [t] status code. The RFC allows servers to use reason phrases besides these in 106 | responses. *) 107 | val default_reason_phrase : t -> string 108 | 109 | (** [long_reason_phrase standard] is an explanation of the the [t] status code. *) 110 | val long_reason_phrase : t -> string 111 | 112 | (** [to_code t] is the integer representation of [t]. *) 113 | val to_code : t -> int 114 | 115 | (** [of_code i] is the [t] representation of [i]. [of_code] raises [Failure] if [i] is not 116 | a positive three-digit number. *) 117 | val of_code : int -> t 118 | 119 | (** [unsafe_of_code i] is equivalent to [of_code i], except it accepts any positive code, 120 | regardless of the number of digits it has. On negative codes, it will still raise 121 | [Failure]. *) 122 | val unsafe_of_code : int -> t 123 | 124 | (** [is_informational t] is true iff [t] belongs to the Informational class of status 125 | codes. *) 126 | val is_informational : t -> bool 127 | 128 | (** [is_successful t] is true iff [t] belongs to the Successful class of status codes. *) 129 | val is_successful : t -> bool 130 | 131 | (** [is_redirection t] is true iff [t] belongs to the Redirection class of status codes. 132 | *) 133 | val is_redirection : t -> bool 134 | 135 | (** [is_client_error t] is true iff [t] belongs to the Client Error class of status codes. 136 | *) 137 | val is_client_error : t -> bool 138 | 139 | (** [is_server_error t] is true iff [t] belongs to the Server Error class of status codes. 140 | *) 141 | val is_server_error : t -> bool 142 | 143 | (** [is_error t] is true iff [t] belongs to the Client Error or Server Error class of 144 | status codes. *) 145 | val is_error : t -> bool 146 | 147 | (** {2 Utilities} *) 148 | 149 | (** [to_string t] returns a string representation of the status [t]. *) 150 | val to_string : t -> string 151 | 152 | (** [of_string s] returns a status from its string representation [s]. *) 153 | val of_string : string -> t 154 | 155 | (** [sexp_of_t t] converts the request [t] to an s-expression *) 156 | val sexp_of_t : t -> Sexplib0.Sexp.t 157 | 158 | (** [pp] formats the request [t] as an s-expression *) 159 | val pp : Format.formatter -> t -> unit 160 | [@@ocaml.toplevel_printer] 161 | 162 | (** [pp_hum] formats the request [t] as a standard HTTP request *) 163 | val pp_hum : Format.formatter -> t -> unit 164 | [@@ocaml.toplevel_printer] 165 | -------------------------------------------------------------------------------- /opium/src/version.ml: -------------------------------------------------------------------------------- 1 | open Import 2 | include Httpaf.Version 3 | 4 | let sexp_of_t version = 5 | let open Sexp_conv in 6 | Sexp.List 7 | [ List [ Atom "major"; sexp_of_int version.major ] 8 | ; List [ Atom "minor"; sexp_of_int version.minor ] 9 | ] 10 | ;; 11 | 12 | let pp fmt t = Sexp.pp_hum fmt (sexp_of_t t) 13 | let pp_hum fmt t = Format.fprintf fmt "%s" (to_string t) 14 | -------------------------------------------------------------------------------- /opium/src/version.mli: -------------------------------------------------------------------------------- 1 | (* A major part of this documentation is extracted from 2 | {{:https://github.com/inhabitedtype/httpaf/blob/master/lib/httpaf.mli}. 3 | 4 | Copyright (c) 2016, Inhabited Type LLC 5 | 6 | All rights reserved.*) 7 | 8 | (** Protocol Version 9 | 10 | HTTP uses a "." numbering scheme to indicate versions of the protocol. 11 | The protocol version as a whole indicates the sender's conformance with the set of 12 | requirements laid out in that version's corresponding specification of HTTP. 13 | 14 | See {{:https://tools.ietf.org/html/rfc7230#section-2.6} RFC7230§2.6} for more details. 15 | *) 16 | 17 | type t = Httpaf.Version.t = 18 | { major : int 19 | ; minor : int 20 | } 21 | 22 | (** [compare x y] returns [0] if version [x] is equal to version [y], a negative integer 23 | if version [x] is less than version [y], and a positive integer if version [x] is 24 | greater than version [y]. *) 25 | val compare : t -> t -> int 26 | 27 | (** [to_string t] returns a string representation of the version [t]. *) 28 | val to_string : t -> string 29 | 30 | (** [of_string s] returns a version from its string representation [s]. *) 31 | val of_string : string -> t 32 | 33 | (** {2 Utilities} *) 34 | 35 | (** [sexp_of_t t] converts the request [t] to an s-expression *) 36 | val sexp_of_t : t -> Sexplib0.Sexp.t 37 | 38 | (** [pp] formats the request [t] as an s-expression *) 39 | val pp : Format.formatter -> t -> unit 40 | [@@ocaml.toplevel_printer] 41 | 42 | (** [pp_hum] formats the request [t] as a standard HTTP request *) 43 | val pp_hum : Format.formatter -> t -> unit 44 | [@@ocaml.toplevel_printer] 45 | -------------------------------------------------------------------------------- /opium/test/cookie.ml: -------------------------------------------------------------------------------- 1 | let headers = [ "Cookie", "yummy_cookie=choco; tasty_cookie=strawberry" ] 2 | 3 | let parse_cookies_of_headers () = 4 | let c1, c2 = 5 | match Opium.Cookie.cookies_of_headers headers with 6 | | [ c1; c2 ] -> c1, c2 7 | | _ -> failwith "Unexpected number of cookies parsed" 8 | in 9 | Alcotest.(check (pair string string) "has cookie" ("yummy_cookie", "choco") c1); 10 | Alcotest.(check (pair string string) "has cookie" ("tasty_cookie", "strawberry") c2); 11 | () 12 | ;; 13 | 14 | let find_cookie_in_headers () = 15 | let cookie = Opium.Cookie.cookie_of_headers "tasty_cookie" headers in 16 | Alcotest.( 17 | check 18 | (option (pair string string)) 19 | "has cookie" 20 | (Some ("tasty_cookie", "strawberry")) 21 | cookie) 22 | ;; 23 | 24 | let () = 25 | Alcotest.run 26 | "Cookie" 27 | [ ( "parse" 28 | , [ "test parse cookies of headers", `Quick, parse_cookies_of_headers 29 | ; "test find cookie in headers", `Quick, find_cookie_in_headers 30 | ] ) 31 | ] 32 | ;; 33 | -------------------------------------------------------------------------------- /opium/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names middleware_allow_cors request response route cookie) 3 | (libraries alcotest alcotest-lwt lwt opium) 4 | (package opium)) 5 | -------------------------------------------------------------------------------- /opium/test/middleware_allow_cors.ml: -------------------------------------------------------------------------------- 1 | open Opium 2 | 3 | let request = Alcotest.of_pp Request.pp_hum 4 | let response = Alcotest.of_pp Response.pp_hum 5 | 6 | let with_service ?middlewares ?handler f = 7 | let handler = 8 | Option.value handler ~default:(fun _req -> Lwt.return @@ Response.make ()) 9 | in 10 | let middlewares = Option.value middlewares ~default:[] in 11 | let app = Rock.App.create ~middlewares ~handler () in 12 | let { Rock.App.middlewares; handler } = app in 13 | let filters = ListLabels.map ~f:(fun m -> m.Rock.Middleware.filter) middlewares in 14 | let service = Rock.Filter.apply_all filters handler in 15 | f service 16 | ;; 17 | 18 | let check_response ?headers ?status res = 19 | let expected = Response.make ?status ?headers:(Option.map Headers.of_list headers) () in 20 | Alcotest.(check response) "same response" expected res 21 | ;; 22 | 23 | let test_regular_request () = 24 | let open Lwt.Syntax in 25 | let+ res = 26 | with_service 27 | ~middlewares:[ Middleware.allow_cors () ] 28 | (fun service -> 29 | let req = Request.make "/" `GET in 30 | service req) 31 | in 32 | check_response 33 | ~headers: 34 | [ "access-control-allow-origin", "*" 35 | ; "access-control-expose-headers", "" 36 | ; "access-control-allow-credentials", "true" 37 | ] 38 | res 39 | ;; 40 | 41 | let test_overwrite_origin () = 42 | let open Lwt.Syntax in 43 | let+ res = 44 | with_service 45 | ~middlewares:[ Middleware.allow_cors ~origins:[ "http://example.com" ] () ] 46 | (fun service -> 47 | let req = 48 | Request.make 49 | "/" 50 | `GET 51 | ~headers:(Headers.of_list [ "origin", "http://example.com" ]) 52 | in 53 | service req) 54 | in 55 | check_response 56 | ~headers: 57 | [ "access-control-allow-origin", "http://example.com" 58 | ; "access-control-expose-headers", "" 59 | ; "access-control-allow-credentials", "true" 60 | ; "vary", "Origin" 61 | ] 62 | res 63 | ;; 64 | 65 | let test_return_204_for_options () = 66 | let open Lwt.Syntax in 67 | let+ res = 68 | with_service 69 | ~middlewares:[ Middleware.allow_cors () ] 70 | (fun service -> 71 | let req = Request.make "/" `OPTIONS in 72 | service req) 73 | in 74 | check_response 75 | ~status:`No_content 76 | ~headers: 77 | [ "access-control-allow-origin", "*" 78 | ; "access-control-expose-headers", "" 79 | ; "access-control-allow-credentials", "true" 80 | ; "access-control-max-age", "1728000" 81 | ; "access-control-allow-methods", "GET,POST,PUT,DELETE,OPTIONS,PATCH" 82 | ; ( "access-control-allow-headers" 83 | , "Authorization,Content-Type,Accept,Origin,User-Agent,DNT,Cache-Control,X-Mx-ReqToken,Keep-Alive,X-Requested-With,If-Modified-Since,X-CSRF-Token" 84 | ) 85 | ] 86 | res 87 | ;; 88 | 89 | let test_allow_request_headers () = 90 | let open Lwt.Syntax in 91 | let+ res = 92 | with_service 93 | ~middlewares:[ Middleware.allow_cors ~headers:[ "*" ] () ] 94 | (fun service -> 95 | let req = 96 | Request.make 97 | "/" 98 | `OPTIONS 99 | ~headers: 100 | (Headers.of_list [ "access-control-request-headers", "header-1,header-2" ]) 101 | in 102 | service req) 103 | in 104 | check_response 105 | ~status:`No_content 106 | ~headers: 107 | [ "access-control-allow-origin", "*" 108 | ; "access-control-expose-headers", "" 109 | ; "access-control-allow-credentials", "true" 110 | ; "access-control-max-age", "1728000" 111 | ; "access-control-allow-methods", "GET,POST,PUT,DELETE,OPTIONS,PATCH" 112 | ; "access-control-allow-headers", "header-1,header-2" 113 | ] 114 | res 115 | ;; 116 | 117 | let () = 118 | Lwt_main.run 119 | @@ Alcotest_lwt.run 120 | "Middleware :: Allow CORS" 121 | [ ( "headers" 122 | , [ "Regular request returns correct headers", `Quick, test_regular_request 123 | ; "Overwrites origin header", `Quick, test_overwrite_origin 124 | ; "Allow incoming request headers", `Quick, test_allow_request_headers 125 | ; ( "Returns No Content for OPTIONS requests" 126 | , `Quick 127 | , test_return_204_for_options ) 128 | ] ) 129 | ] 130 | ;; 131 | -------------------------------------------------------------------------------- /opium/test/route.ml: -------------------------------------------------------------------------------- 1 | open Sexplib0 2 | module Route = Opium.Route 3 | 4 | let slist t = Alcotest.slist t compare 5 | let params = slist Alcotest.(pair string string) 6 | 7 | let matches_t : Route.matches Alcotest.testable = 8 | (module struct 9 | type t = Route.matches 10 | 11 | let equal r1 r2 = r1.Route.splat = r2.Route.splat && r1.Route.params = r2.Route.params 12 | let pp f t = Sexp.pp_hum f (Route.sexp_of_matches t) 13 | end) 14 | ;; 15 | 16 | let match_get_params route url = 17 | match Route.match_url route url with 18 | | None -> None 19 | | Some { Route.params; _ } -> Some params 20 | ;; 21 | 22 | let string_of_match = function 23 | | None -> "None" 24 | | Some m -> 25 | let open Sexp_conv in 26 | Sexp.to_string_hum (sexp_of_list (sexp_of_pair sexp_of_string sexp_of_string) m) 27 | ;; 28 | 29 | let simple_route1 () = 30 | let r = Route.of_string "/test/:id" in 31 | Alcotest.(check (option params) "no match" None (match_get_params r "/test/blerg/123")); 32 | Alcotest.( 33 | check (option params) "match" (match_get_params r "/test/123") (Some [ "id", "123" ])) 34 | ;; 35 | 36 | let simple_route2 () = 37 | let r = Route.of_string "/test/:format/:name" in 38 | let m = match_get_params r "/test/json/bar" in 39 | Alcotest.(check (option params) "" m (Some [ "format", "json"; "name", "bar" ])) 40 | ;; 41 | 42 | let simple_route3 () = 43 | let r = Route.of_string "/test/:format/:name" in 44 | let m = Route.match_url r "/test/bar" in 45 | Alcotest.(check (option matches_t) "unexpected match" None m) 46 | ;; 47 | 48 | let route_no_slash () = 49 | let r = Route.of_string "/xxx/:title" in 50 | let m = Route.match_url r "/xxx/../" in 51 | Alcotest.(check (option matches_t) "unexpected match" None m) 52 | ;; 53 | 54 | let splat_route1 () = 55 | let r = Route.of_string "/test/*/:id" in 56 | let matches = Route.match_url r "/test/splat/123" in 57 | Alcotest.( 58 | check 59 | (option matches_t) 60 | "matches" 61 | (Some { Route.params = [ "id", "123" ]; splat = [ "splat" ] }) 62 | matches) 63 | ;; 64 | 65 | let splat_route2 () = 66 | let r = Route.of_string "/*" in 67 | let m = Route.match_url r "/abc/123" in 68 | Alcotest.(check (option matches_t) "unexpected match" None m) 69 | ;; 70 | 71 | let splat_route3 () = 72 | let r = Route.of_string "/*/*/*" in 73 | let matches = Route.match_url r "/test/splat/123" in 74 | Alcotest.( 75 | check 76 | (option matches_t) 77 | "matches" 78 | (Some { Route.params = []; splat = [ "test"; "splat"; "123" ] }) 79 | matches) 80 | ;; 81 | 82 | let test_match_2_params () = 83 | let r = Route.of_string "/xxx/:x/:y" in 84 | let m = match_get_params r "/xxx/123/456" in 85 | Alcotest.(check (option params) "" (Some [ "x", "123"; "y", "456" ]) m) 86 | ;; 87 | 88 | let test_match_no_param () = 89 | let r = Route.of_string "/version" in 90 | let m1, m2 = Route.(match_url r "/version", match_url r "/tt") in 91 | match m1, m2 with 92 | | Some _, None -> () 93 | | _, _ -> Alcotest.fail "bad match" 94 | ;; 95 | 96 | let test_empty_route () = 97 | let r = Route.of_string "/" in 98 | let m s = 99 | match Route.match_url r s with 100 | | None -> false 101 | | Some _ -> true 102 | in 103 | let m1, m2 = m "/", m "/testing" in 104 | Alcotest.(check bool "match '/'" true m1); 105 | Alcotest.(check bool "not match '/testing'" false m2) 106 | ;; 107 | 108 | let printer x = x 109 | let str_t s = s |> Route.of_string |> Route.to_string 110 | let string_convert_1 () = Alcotest.(check string "" "/" (str_t "/")) 111 | let string_convert_2 () = Alcotest.(check string "" "/one/:two" (str_t "/one/:two")) 112 | 113 | let string_convert_3 () = 114 | Alcotest.(check string "" "/one/two/*/three" (str_t "/one/two/*/three")) 115 | ;; 116 | 117 | let escape_param_1 () = 118 | let r = Route.of_string "/:pp/*" in 119 | let matches = Route.match_url r "/%23/%23a" in 120 | Alcotest.( 121 | check 122 | (option matches_t) 123 | "matches" 124 | (Some { Route.params = [ "pp", "#" ]; splat = [ "#a" ] }) 125 | matches) 126 | ;; 127 | 128 | let empty_route () = 129 | let r = Route.of_string "" in 130 | Alcotest.( 131 | check 132 | (option matches_t) 133 | "" 134 | (Some { Route.params = []; splat = [] }) 135 | (Route.match_url r "")) 136 | ;; 137 | 138 | let test_double_splat () = 139 | let r = Route.of_string "/**" in 140 | let matching_urls = 141 | [ "/test", [ "test" ]; "/", []; "/user/123/foo/bar", [ "user"; "123"; "foo"; "bar" ] ] 142 | in 143 | matching_urls 144 | |> List.iter (fun (u, splat) -> 145 | Alcotest.( 146 | check 147 | (option matches_t) 148 | "matches" 149 | (Some { Route.params = []; splat }) 150 | (Route.match_url r u))) 151 | ;; 152 | 153 | let test_double_splat_escape () = 154 | let r = Route.of_string "/**" in 155 | let matches = Route.match_url r "/%23/%23a" in 156 | Alcotest.( 157 | check 158 | (option matches_t) 159 | "matches" 160 | (Some { Route.params = []; splat = [ "#"; "#a" ] }) 161 | matches) 162 | ;; 163 | 164 | let test_query_params_dont_impact_match () = 165 | let r2 = Route.of_string "/foo/:message" in 166 | Alcotest.( 167 | check (option params) "" (match_get_params r2 "/foo/bar") (Some [ "message", "bar" ])); 168 | Alcotest.( 169 | check 170 | (option params) 171 | "" 172 | (match_get_params r2 "/foo/bar?key=12") 173 | (Some [ "message", "bar" ])) 174 | ;; 175 | 176 | let () = 177 | Alcotest.run 178 | "Route" 179 | [ ( "match" 180 | , [ "test match no param", `Quick, test_match_no_param 181 | ; "test match 1", `Quick, simple_route1 182 | ; "test match 2", `Quick, simple_route2 183 | ; "test match 3", `Quick, simple_route3 184 | ; "test match 2 params", `Quick, test_match_2_params 185 | ] ) 186 | ; ( "splat" 187 | , [ "splat match 1", `Quick, splat_route1 188 | ; "splat match 2", `Quick, splat_route2 189 | ; "splat match 3", `Quick, splat_route3 190 | ; "test double splat", `Quick, test_double_splat 191 | ] ) 192 | ; ( "conversion" 193 | , [ "test string conversion 1", `Quick, string_convert_1 194 | ; "test string conversion 2", `Quick, string_convert_2 195 | ; "test string conversion 3", `Quick, string_convert_3 196 | ] ) 197 | ; ( "empty" 198 | , [ "test empty route", `Quick, test_empty_route 199 | ; "empty route", `Quick, empty_route 200 | ] ) 201 | ; "escape", [ "test escape param", `Quick, escape_param_1 ] 202 | ; ( "query params" 203 | , [ ( "test query params dont impact match" 204 | , `Quick 205 | , test_query_params_dont_impact_match ) 206 | ; "test double splat escape", `Quick, test_double_splat_escape 207 | ] ) 208 | ] 209 | ;; 210 | -------------------------------------------------------------------------------- /rock.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Minimalist framework to build extensible HTTP servers and clients" 4 | description: 5 | "Rock is a Unix indpendent API to build extensible HTTP servers and clients. It provides building blocks such as middlewares and handlers (a.k.a controllers)." 6 | maintainer: ["Rudi Grinberg "] 7 | authors: ["Rudi Grinberg" "Anurag Soni" "Thibaut Mattio"] 8 | license: "MIT" 9 | homepage: "https://github.com/rgrinberg/opium" 10 | doc: "https://rgrinberg.github.io/opium/" 11 | bug-reports: "https://github.com/rgrinberg/opium/issues" 12 | depends: [ 13 | "dune" {>= "2.0"} 14 | "ocaml" {>= "4.08"} 15 | "lwt" {>= "5.3.0"} 16 | "bigstringaf" 17 | "hmap" 18 | "httpaf" 19 | "lwt" 20 | "sexplib0" 21 | "odoc" {with-doc} 22 | ] 23 | build: [ 24 | ["dune" "subst"] {pinned} 25 | [ 26 | "dune" 27 | "build" 28 | "-p" 29 | name 30 | "-j" 31 | jobs 32 | "@install" 33 | "@runtest" {with-test} 34 | "@doc" {with-doc} 35 | ] 36 | ] 37 | dev-repo: "git+https://github.com/rgrinberg/opium.git" 38 | -------------------------------------------------------------------------------- /rock/doc/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package rock)) 3 | -------------------------------------------------------------------------------- /rock/doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Rock} 2 | 3 | Rock provides finagle inspired Service/Filter abstractions to write HTTP services. 4 | 5 | {2 Services} 6 | 7 | Services are simple functions that work on a request, and returns a promise representing the eventual result (or failure). 8 | Its represented with the following type: 9 | 10 | {[ 11 | type ('req, 'res) t = 'req -> 'res Lwt.t 12 | ]} 13 | 14 | Services can be used to represent any operation and not necessarily something related to HTTP. 15 | As an example we can have a service that works on integers and returns a string response: 16 | 17 | {[ 18 | let my_simple_service : (int, string) Service.t = 19 | fun request -> Lwt.return (string_of_int request) 20 | ;; 21 | ]} 22 | 23 | In Rock HTTP handlers are also represented as services. They have the type: 24 | 25 | {[ 26 | type handler = (Request.t, Response.t) Service.t 27 | ]} 28 | 29 | With this type, one can have an HTTP server like: 30 | {[ 31 | open Rock.Rock 32 | 33 | let http_service req = 34 | Lwt.return (Response.of_string "Hello World\n") 35 | ;; 36 | ]} 37 | 38 | Services (For web services these are Rock.Handler) are used to implement an application's business logic. 39 | 40 | {2 Filters} 41 | 42 | Filters are also functions, instead of a request they work on services. They can be used to 43 | transform a service by performing some specific functions on the request or response, before/after the user's http service. 44 | This can be useful to enhance your application with some functionality that needs to shared by multiple services, things like 45 | logging, compression, authentication etc. 46 | 47 | Example of a simple filter working on the service defined earlier in the page: 48 | 49 | {[ 50 | let add_two_filter service = 51 | fun req -> 52 | service (req + 2) 53 | ;; 54 | 55 | let new_service = add_two_filter my_simple_service;; 56 | ]} 57 | 58 | {1 API documentation} 59 | 60 | {!modules: 61 | Rock 62 | } 63 | -------------------------------------------------------------------------------- /rock/src/app.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { middlewares : Middleware.t list 3 | ; handler : Handler.t 4 | } 5 | 6 | let append_middleware t m = { t with middlewares = t.middlewares @ [ m ] } 7 | let create ?(middlewares = []) ~handler () = { middlewares; handler } 8 | -------------------------------------------------------------------------------- /rock/src/app.mli: -------------------------------------------------------------------------------- 1 | type t = private 2 | { middlewares : Middleware.t list 3 | ; handler : Handler.t 4 | } 5 | 6 | val append_middleware : t -> Middleware.t -> t 7 | val create : ?middlewares:Middleware.t list -> handler:Handler.t -> unit -> t 8 | -------------------------------------------------------------------------------- /rock/src/body.ml: -------------------------------------------------------------------------------- 1 | type content = 2 | [ `Empty 3 | | `String of string 4 | | `Bigstring of Bigstringaf.t 5 | | (* TODO: switch to a iovec based stream *) 6 | `Stream of string Lwt_stream.t 7 | ] 8 | 9 | type t = 10 | { length : Int64.t option 11 | ; content : content 12 | } 13 | 14 | let length t = t.length 15 | 16 | let escape_html s = 17 | let b = Buffer.create 42 in 18 | for i = 0 to String.length s - 1 do 19 | match s.[i] with 20 | | ('&' | '<' | '>' | '\'' | '"') as c -> Printf.bprintf b "&#%d;" (int_of_char c) 21 | | c -> Buffer.add_char b c 22 | done; 23 | Buffer.contents b 24 | ;; 25 | 26 | let sexp_of_content content = 27 | let open Sexplib0.Sexp_conv in 28 | match content with 29 | | `Empty -> sexp_of_string "" 30 | | `String s -> sexp_of_string (escape_html s) 31 | | `Bigstring b -> sexp_of_string (escape_html (Bigstringaf.to_string b)) 32 | | `Stream s -> sexp_of_opaque s 33 | ;; 34 | 35 | let sexp_of_t { length; content } = 36 | let open Sexplib0 in 37 | let len = Sexp_conv.sexp_of_option Sexp_conv.sexp_of_int64 in 38 | Sexp.( 39 | List 40 | [ List [ Atom "length"; len length ] 41 | ; List [ Atom "content"; sexp_of_content content ] 42 | ]) 43 | ;; 44 | 45 | let drain { content; _ } = 46 | match content with 47 | | `Stream stream -> Lwt_stream.junk_while (fun _ -> true) stream 48 | | _ -> Lwt.return_unit 49 | ;; 50 | 51 | let to_string { content; _ } = 52 | let open Lwt.Syntax in 53 | match content with 54 | | `Stream content -> 55 | let buf = Buffer.create 1024 in 56 | let+ () = Lwt_stream.iter (fun s -> Buffer.add_string buf s) content in 57 | Buffer.contents buf 58 | | `String s -> Lwt.return s 59 | | `Bigstring b -> Lwt.return (Bigstringaf.to_string b) 60 | | `Empty -> Lwt.return "" 61 | ;; 62 | 63 | let to_stream { content; _ } = 64 | match content with 65 | | `Empty -> Lwt_stream.of_list [] 66 | | `String s -> Lwt_stream.of_list [ s ] 67 | | `Bigstring b -> Lwt_stream.of_list [ Bigstringaf.to_string b ] 68 | | `Stream s -> s 69 | ;; 70 | 71 | let len x = Some (Int64.of_int x) 72 | let of_string s = { content = `String s; length = len (String.length s) } 73 | let of_bigstring b = { content = `Bigstring b; length = len (Bigstringaf.length b) } 74 | let empty = { content = `Empty; length = Some 0L } 75 | let of_stream ?length s = { content = `Stream s; length } 76 | 77 | let copy t = 78 | match t.content with 79 | | `Empty -> t 80 | | `String _ -> t 81 | | `Bigstring _ -> t 82 | | `Stream stream -> { t with content = `Stream (Lwt_stream.clone stream) } 83 | ;; 84 | 85 | let pp fmt t = Sexplib0.Sexp.pp_hum fmt (sexp_of_t t) 86 | 87 | let pp_hum fmt t = 88 | Format.fprintf 89 | fmt 90 | "%s" 91 | (match t.content with 92 | | `Empty -> "" 93 | | `String s -> s 94 | | `Bigstring b -> Bigstringaf.to_string b 95 | | `Stream _ -> "") 96 | ;; 97 | -------------------------------------------------------------------------------- /rock/src/body.mli: -------------------------------------------------------------------------------- 1 | (** Represents an HTTP request or response body. *) 2 | 3 | type content = 4 | [ `Empty 5 | | `String of string 6 | | `Bigstring of Bigstringaf.t 7 | | (* TODO: switch to a iovec based stream *) 8 | `Stream of string Lwt_stream.t 9 | ] 10 | 11 | (** [t] represents an HTTP message body. *) 12 | type t = 13 | { length : Int64.t option 14 | ; content : content 15 | } 16 | 17 | (** {1 Constructor} *) 18 | 19 | (** [of_string] creates a fixed length body from a string. *) 20 | val of_string : string -> t 21 | 22 | (** [of_bigstring] creates a fixed length body from a bigstring. *) 23 | val of_bigstring : Bigstringaf.t -> t 24 | 25 | (** [of_stream] takes a [string Lwt_stream.t] and creates a HTTP body from it. *) 26 | val of_stream : ?length:Int64.t -> string Lwt_stream.t -> t 27 | 28 | (** [empty] represents a body of size 0L. *) 29 | val empty : t 30 | 31 | (** [copy t] creates a new instance of the body [t]. If the body is a stream, it is be 32 | duplicated safely and the initial stream will remain untouched. *) 33 | val copy : t -> t 34 | 35 | (** {1 Decoders} *) 36 | 37 | (** [to_string t] returns a promise that will eventually be filled with a string 38 | representation of the body. *) 39 | val to_string : t -> string Lwt.t 40 | 41 | (** [to_stream t] converts the body to a [string Lwt_stream.t]. *) 42 | val to_stream : t -> string Lwt_stream.t 43 | 44 | (** {1 Getters and Setters} *) 45 | 46 | val length : t -> Int64.t option 47 | 48 | (** {1 Utilities} *) 49 | 50 | (** [drain t] will repeatedly read values from the body stream and discard them. *) 51 | val drain : t -> unit Lwt.t 52 | 53 | (** [sexp_of_t t] converts the body [t] to an s-expression *) 54 | val sexp_of_t : t -> Sexplib0.Sexp.t 55 | 56 | (** [pp] formats the body [t] as an s-expression *) 57 | val pp : Format.formatter -> t -> unit 58 | [@@ocaml.toplevel_printer] 59 | 60 | (** [pp_hum] formats the body [t] as an string. 61 | 62 | If the body content is a stream, the pretty printer will output the value [""]*) 63 | val pp_hum : Format.formatter -> t -> unit 64 | [@@ocaml.toplevel_printer] 65 | -------------------------------------------------------------------------------- /rock/src/context.ml: -------------------------------------------------------------------------------- 1 | include Hmap.Make (struct 2 | type 'a t = string * ('a -> Sexplib0.Sexp.t) 3 | end) 4 | -------------------------------------------------------------------------------- /rock/src/context.mli: -------------------------------------------------------------------------------- 1 | (** A context holds heterogeneous value and is passed to the requests or responses. *) 2 | 3 | (** {2:keys Keys} *) 4 | 5 | (** The type for keys whose lookup value is of type ['a]. *) 6 | type 'a key 7 | 8 | (** {3 [Key]} *) 9 | 10 | module Key : sig 11 | (** {2:keys Keys} *) 12 | 13 | (** The type for key information. *) 14 | type 'a info = string * ('a -> Sexplib0.Sexp.t) 15 | 16 | (** {3 [create]} *) 17 | 18 | (** [create i] is a new key with information [i]. *) 19 | val create : 'a info -> 'a key 20 | 21 | (** {3 [info]} *) 22 | 23 | (** [info k] is [k]'s information. *) 24 | val info : 'a key -> 'a info 25 | 26 | (** {2:exists Existential keys} 27 | 28 | Exisential keys allow to compare keys. This can be useful for functions like 29 | {!filter}. *) 30 | 31 | (** The type for existential keys. *) 32 | type t 33 | 34 | (** {3 [hide_type]} *) 35 | 36 | (** [hide_type k] is an existential key for [k]. *) 37 | val hide_type : 'a key -> t 38 | 39 | (** {3 [equal]} *) 40 | 41 | (** [equal k k'] is [true] iff [k] and [k'] are the same key. *) 42 | val equal : t -> t -> bool 43 | 44 | (** {3 [compare]} *) 45 | 46 | (** [compare k k'] is a total order on keys compatible with {!equal}. *) 47 | val compare : t -> t -> int 48 | end 49 | 50 | (** {1:maps Maps} *) 51 | 52 | (** The type for heterogeneous value maps. *) 53 | type t 54 | 55 | (** [empty] is the empty map. *) 56 | val empty : t 57 | 58 | (** [is_empty m] is [true] iff [m] is empty. *) 59 | val is_empty : t -> bool 60 | 61 | (** [mem k m] is [true] iff [k] is bound in [m]. *) 62 | val mem : 'a key -> t -> bool 63 | 64 | (** [add k v m] is [m] with [k] bound to [v]. *) 65 | val add : 'a key -> 'a -> t -> t 66 | 67 | (** [singleton k v] is [add k v empty]. *) 68 | val singleton : 'a key -> 'a -> t 69 | 70 | (** [rem k m] is [m] with [k] unbound. *) 71 | val rem : 'a key -> t -> t 72 | 73 | (** [find k m] is the value of [k]'s binding in [m], if any. *) 74 | val find : 'a key -> t -> 'a option 75 | 76 | (** [get k m] is the value of [k]'s binding in [m]. 77 | 78 | @raise Invalid_argument if [k] is not bound in [m]. *) 79 | val get : 'a key -> t -> 'a 80 | 81 | (** The type for bindings. *) 82 | type binding = B : 'a key * 'a -> binding 83 | 84 | (** [iter f m] applies [f] to all bindings of [m]. *) 85 | val iter : (binding -> unit) -> t -> unit 86 | 87 | (** [fold f m acc] folds over the bindings of [m] with [f], starting with [acc] *) 88 | val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a 89 | 90 | (** [for_all p m] is [true] iff all bindings of [m] satisfy [p]. *) 91 | val for_all : (binding -> bool) -> t -> bool 92 | 93 | (** [exists p m] is [true] iff there exists a bindings of [m] that satisfies [p]. *) 94 | val exists : (binding -> bool) -> t -> bool 95 | 96 | (** [filter p m] are the bindings of [m] that satisfy [p]. *) 97 | val filter : (binding -> bool) -> t -> t 98 | 99 | (** [cardinal m] is the number of bindings in [m]. *) 100 | val cardinal : t -> int 101 | 102 | (** [any_binding m] is a binding of [m] (if not empty). *) 103 | val any_binding : t -> binding option 104 | 105 | (** [get_any_binding m] is a binding of [m]. 106 | 107 | @raise Invalid_argument if [m] is empty. *) 108 | val get_any_binding : t -> binding 109 | -------------------------------------------------------------------------------- /rock/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name rock) 3 | (libraries bigstringaf hmap httpaf lwt sexplib0)) 4 | -------------------------------------------------------------------------------- /rock/src/filter.ml: -------------------------------------------------------------------------------- 1 | type ('req, 'rep, 'req_, 'rep_) t = ('req, 'rep) Service.t -> ('req_, 'rep_) Service.t 2 | type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t 3 | 4 | let ( >>> ) f1 f2 s = s |> f1 |> f2 5 | let apply_all filters service = ListLabels.fold_left filters ~init:service ~f:( |> ) 6 | -------------------------------------------------------------------------------- /rock/src/filter.mli: -------------------------------------------------------------------------------- 1 | (** A filter is a higher order function that transforms a service into another service. *) 2 | 3 | type ('req, 'rep, 'req', 'rep') t = ('req, 'rep) Service.t -> ('req', 'rep') Service.t 4 | 5 | (** A filter is simple when it preserves the type of a service *) 6 | type ('req, 'rep) simple = ('req, 'rep, 'req, 'rep) t 7 | 8 | val ( >>> ) : ('q1, 'p1, 'q2, 'p2) t -> ('q2, 'p2, 'q3, 'p3) t -> ('q1, 'p1, 'q3, 'p3) t 9 | 10 | val apply_all 11 | : ('req, 'rep) simple list 12 | -> ('req, 'rep) Service.t 13 | -> ('req, 'rep) Service.t 14 | -------------------------------------------------------------------------------- /rock/src/handler.ml: -------------------------------------------------------------------------------- 1 | type t = (Request.t, Response.t) Service.t 2 | -------------------------------------------------------------------------------- /rock/src/handler.mli: -------------------------------------------------------------------------------- 1 | (** A handler is a rock specific service. *) 2 | 3 | type t = (Request.t, Response.t) Service.t 4 | -------------------------------------------------------------------------------- /rock/src/middleware.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { filter : (Request.t, Response.t) Filter.simple 3 | ; name : string 4 | } 5 | 6 | let create ~filter ~name = { filter; name } 7 | let apply { filter; _ } handler = filter handler 8 | -------------------------------------------------------------------------------- /rock/src/middleware.mli: -------------------------------------------------------------------------------- 1 | (** Middleware is a named, simple filter, that only works on rock requests/response. *) 2 | 3 | type t = private 4 | { filter : (Request.t, Response.t) Filter.simple 5 | ; name : string 6 | } 7 | 8 | val create : filter:(Request.t, Response.t) Filter.simple -> name:string -> t 9 | val apply : t -> Handler.t -> Handler.t 10 | -------------------------------------------------------------------------------- /rock/src/request.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { version : Httpaf.Version.t 3 | ; target : string 4 | ; headers : Httpaf.Headers.t 5 | ; meth : Httpaf.Method.t 6 | ; body : Body.t 7 | ; env : Context.t 8 | } 9 | 10 | let client_address = 11 | Context.Key.create ("client address", Sexplib0.Sexp_conv.sexp_of_string) 12 | ;; 13 | 14 | let make 15 | ?(version = { Httpaf.Version.major = 1; minor = 1 }) 16 | ?(body = Body.empty) 17 | ?(env = Context.empty) 18 | ?(headers = Httpaf.Headers.empty) 19 | target 20 | meth 21 | = 22 | { version; target; headers; meth; body; env } 23 | ;; 24 | 25 | let with_client_address t addr = { t with env = Context.add client_address addr t.env } 26 | let client_address t = Context.find client_address t.env 27 | 28 | let get ?version ?body ?env ?headers target = 29 | make ?version ?body ?env ?headers target `GET 30 | ;; 31 | 32 | let post ?version ?body ?env ?headers target = 33 | make ?version ?body ?env ?headers target `POST 34 | ;; 35 | 36 | let put ?version ?body ?env ?headers target = 37 | make ?version ?body ?env ?headers target `PUT 38 | ;; 39 | 40 | let delete ?version ?body ?env ?headers target = 41 | make ?version ?body ?env ?headers target `DELETE 42 | ;; 43 | -------------------------------------------------------------------------------- /rock/src/request.mli: -------------------------------------------------------------------------------- 1 | (** Module to create HTTP requests. *) 2 | 3 | type t = 4 | { version : Httpaf.Version.t 5 | ; target : string 6 | ; headers : Httpaf.Headers.t 7 | ; meth : Httpaf.Method.t 8 | ; body : Body.t 9 | ; env : Context.t 10 | } 11 | 12 | (** {1 Constructors} *) 13 | 14 | (** {3 [make]} *) 15 | 16 | (** [make ?version ?body ?env ?headers target method] creates a new request from the given 17 | values. 18 | 19 | By default, the HTTP version will be set to 1.1 and the request will not contain any 20 | header or body. *) 21 | val make 22 | : ?version:Httpaf.Version.t 23 | -> ?body:Body.t 24 | -> ?env:Context.t 25 | -> ?headers:Httpaf.Headers.t 26 | -> string 27 | -> Httpaf.Method.t 28 | -> t 29 | 30 | (** {3 [get]} *) 31 | 32 | (** [get ?version ?body ?env ?headers target] creates a new [GET] request from the given 33 | values. 34 | 35 | By default, the HTTP version will be set to 1.1 and the request will not contain any 36 | header or body. *) 37 | val get 38 | : ?version:Httpaf.Version.t 39 | -> ?body:Body.t 40 | -> ?env:Context.t 41 | -> ?headers:Httpaf.Headers.t 42 | -> string 43 | -> t 44 | 45 | (** {3 [post]} *) 46 | 47 | (** [post ?version ?body ?env ?headers target] creates a new [POST] request from the given 48 | values. 49 | 50 | By default, the HTTP version will be set to 1.1 and the request will not contain any 51 | header or body. *) 52 | val post 53 | : ?version:Httpaf.Version.t 54 | -> ?body:Body.t 55 | -> ?env:Context.t 56 | -> ?headers:Httpaf.Headers.t 57 | -> string 58 | -> t 59 | 60 | (** {3 [put]} *) 61 | 62 | (** [put ?version ?body ?env ?headers target] creates a new [PUT] request from the given 63 | values. 64 | 65 | By default, the HTTP version will be set to 1.1 and the request will not contain any 66 | header or body. *) 67 | val put 68 | : ?version:Httpaf.Version.t 69 | -> ?body:Body.t 70 | -> ?env:Context.t 71 | -> ?headers:Httpaf.Headers.t 72 | -> string 73 | -> t 74 | 75 | (** {3 [delete]} *) 76 | 77 | (** [delete ?version ?body ?env ?headers target] creates a new [DELETE] request from the 78 | given values. 79 | 80 | By default, the HTTP version will be set to 1.1 and the request will not contain any 81 | header or body. *) 82 | val delete 83 | : ?version:Httpaf.Version.t 84 | -> ?body:Body.t 85 | -> ?env:Context.t 86 | -> ?headers:Httpaf.Headers.t 87 | -> string 88 | -> t 89 | 90 | val with_client_address : t -> string -> t 91 | val client_address : t -> string option 92 | -------------------------------------------------------------------------------- /rock/src/response.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { version : Httpaf.Version.t 3 | ; status : Httpaf.Status.t 4 | ; reason : string option 5 | ; headers : Httpaf.Headers.t 6 | ; body : Body.t 7 | ; env : Context.t 8 | } 9 | 10 | let make 11 | ?(version = { Httpaf.Version.major = 1; minor = 1 }) 12 | ?(status = `OK) 13 | ?reason 14 | ?(headers = Httpaf.Headers.empty) 15 | ?(body = Body.empty) 16 | ?(env = Context.empty) 17 | () 18 | = 19 | { version; status; reason; headers; body; env } 20 | ;; 21 | -------------------------------------------------------------------------------- /rock/src/response.mli: -------------------------------------------------------------------------------- 1 | (** Module to create HTTP responses. *) 2 | 3 | type t = 4 | { version : Httpaf.Version.t 5 | ; status : Httpaf.Status.t 6 | ; reason : string option 7 | ; headers : Httpaf.Headers.t 8 | ; body : Body.t 9 | ; env : Context.t 10 | } 11 | 12 | (** {1 Constructors} *) 13 | 14 | (** {3 [make]} *) 15 | 16 | (** [make ?version ?status ?reason ?headers ?body ?env ()] creates a new response from the 17 | given values. 18 | 19 | By default, the HTTP version will be set to 1.1, the HTTP status to 200 and the 20 | response will not contain any header or body. *) 21 | val make 22 | : ?version:Httpaf.Version.t 23 | -> ?status:Httpaf.Status.t 24 | -> ?reason:string 25 | -> ?headers:Httpaf.Headers.t 26 | -> ?body:Body.t 27 | -> ?env:Context.t 28 | -> unit 29 | -> t 30 | -------------------------------------------------------------------------------- /rock/src/rock.ml: -------------------------------------------------------------------------------- 1 | module App = App 2 | module Context = Context 3 | module Body = Body 4 | module Request = Request 5 | module Response = Response 6 | module Server_connection = Server_connection 7 | module Service = Service 8 | module Filter = Filter 9 | module Handler = Handler 10 | module Middleware = Middleware 11 | -------------------------------------------------------------------------------- /rock/src/rock.mli: -------------------------------------------------------------------------------- 1 | (** A tiny clone of ruby's Rack protocol in OCaml. Which is slightly more general and 2 | inspired by Finagle. It's not imperative to have this to for such a tiny framework but 3 | it makes extensions a lot more straightforward *) 4 | 5 | module App = App 6 | module Context = Context 7 | module Request = Request 8 | module Response = Response 9 | module Body = Body 10 | module Service = Service 11 | module Filter = Filter 12 | module Handler = Handler 13 | module Middleware = Middleware 14 | module Server_connection = Server_connection 15 | -------------------------------------------------------------------------------- /rock/src/server_connection.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | exception Halt of Response.t 4 | 5 | let halt response = raise (Halt response) 6 | 7 | type error_handler = 8 | string 9 | -> Httpaf.Headers.t 10 | -> Httpaf.Server_connection.error 11 | -> (Httpaf.Headers.t * Body.t) Lwt.t 12 | 13 | let default_error_handler _sockaddr headers error = 14 | let message = 15 | let open Httpaf in 16 | match error with 17 | | `Exn _e -> 18 | (* TODO: log error *) 19 | Status.default_reason_phrase `Internal_server_error 20 | | (#Status.server_error | #Status.client_error) as error -> 21 | Status.default_reason_phrase error 22 | in 23 | let len = Int.to_string (String.length message) in 24 | let headers = Httpaf.Headers.replace headers "Content-Length" len in 25 | Lwt.return (headers, Body.of_string message) 26 | ;; 27 | 28 | let to_httpaf_error_handler handler = 29 | let error_handler sockaddr ?request error start_response = 30 | let req_headers = 31 | match request with 32 | | None -> Httpaf.Headers.empty 33 | | Some req -> req.Httpaf.Request.headers 34 | in 35 | Lwt.async (fun () -> 36 | let* headers, body = handler sockaddr req_headers error in 37 | let headers = 38 | match Body.length body with 39 | | None -> headers 40 | | Some l -> 41 | Httpaf.Headers.add_unless_exists headers "Content-Length" (Int64.to_string l) 42 | in 43 | let res_body = start_response headers in 44 | let+ () = 45 | Lwt_stream.iter 46 | (fun s -> Httpaf.Body.write_string res_body s) 47 | (Body.to_stream body) 48 | in 49 | Httpaf.Body.close_writer res_body) 50 | in 51 | error_handler 52 | ;; 53 | 54 | let read_httpaf_body body = 55 | Lwt_stream.from (fun () -> 56 | let promise, wakeup = Lwt.wait () in 57 | let on_eof () = Lwt.wakeup_later wakeup None in 58 | let on_read buf ~off ~len = 59 | let b = Bytes.create len in 60 | Bigstringaf.blit_to_bytes buf ~src_off:off ~dst_off:0 ~len b; 61 | Lwt.wakeup_later wakeup (Some (Bytes.unsafe_to_string b)) 62 | in 63 | Httpaf.Body.schedule_read body ~on_eof ~on_read; 64 | promise) 65 | ;; 66 | 67 | let httpaf_request_to_request ?body req = 68 | let headers = 69 | req.Httpaf.Request.headers |> Httpaf.Headers.to_list |> Httpaf.Headers.of_rev_list 70 | in 71 | Request.make ~headers ?body req.target req.meth 72 | ;; 73 | 74 | let to_httpaf_request_handler peer_addr app = 75 | let { App.middlewares; handler } = app in 76 | let filters = ListLabels.map ~f:(fun m -> m.Middleware.filter) middlewares in 77 | let service = Filter.apply_all filters handler in 78 | fun reqd -> 79 | Lwt.async (fun () -> 80 | let req = Httpaf.Reqd.request reqd in 81 | let req_body = Httpaf.Reqd.request_body reqd in 82 | let length = 83 | match Httpaf.Request.body_length req with 84 | | `Chunked -> None 85 | | `Fixed l -> Some l 86 | | `Error _ -> failwith "Bad request" 87 | in 88 | let body = 89 | let stream = read_httpaf_body req_body in 90 | Lwt.on_termination (Lwt_stream.closed stream) (fun () -> 91 | Httpaf.Body.close_reader req_body); 92 | Body.of_stream ?length stream 93 | in 94 | let write_fixed_response ~headers f status body = 95 | f reqd (Httpaf.Response.create ~headers status) body; 96 | Lwt.return_unit 97 | in 98 | let request = 99 | Request.with_client_address (httpaf_request_to_request ~body req) peer_addr 100 | in 101 | Lwt.catch 102 | (fun () -> 103 | let* { Response.body; headers; status; _ } = 104 | Lwt.catch 105 | (fun () -> service request) 106 | (function 107 | | Halt response -> Lwt.return response 108 | | exn -> Lwt.fail exn) 109 | in 110 | let { Body.length; _ } = body in 111 | let headers = 112 | match length with 113 | | None -> 114 | Httpaf.Headers.add_unless_exists headers "Transfer-Encoding" "chunked" 115 | | Some l -> 116 | Httpaf.Headers.add_unless_exists 117 | headers 118 | "Content-Length" 119 | (Int64.to_string l) 120 | in 121 | match body.content with 122 | | `Empty -> 123 | write_fixed_response ~headers Httpaf.Reqd.respond_with_string status "" 124 | | `String s -> 125 | write_fixed_response ~headers Httpaf.Reqd.respond_with_string status s 126 | | `Bigstring b -> 127 | write_fixed_response ~headers Httpaf.Reqd.respond_with_bigstring status b 128 | | `Stream s -> 129 | let rb = 130 | Httpaf.Reqd.respond_with_streaming 131 | reqd 132 | (Httpaf.Response.create ~headers status) 133 | in 134 | let+ () = Lwt_stream.iter (fun s -> Httpaf.Body.write_string rb s) s in 135 | Httpaf.Body.flush rb (fun () -> Httpaf.Body.close_writer rb)) 136 | (fun exn -> 137 | Httpaf.Reqd.report_exn reqd exn; 138 | Lwt.return_unit)) 139 | ;; 140 | -------------------------------------------------------------------------------- /rock/src/server_connection.mli: -------------------------------------------------------------------------------- 1 | (** Collection of functions to run a server from a Rock app. *) 2 | 3 | type error_handler = 4 | string 5 | -> Httpaf.Headers.t 6 | -> Httpaf.Server_connection.error 7 | -> (Httpaf.Headers.t * Body.t) Lwt.t 8 | 9 | val to_httpaf_error_handler 10 | : error_handler 11 | -> string 12 | -> Httpaf.Server_connection.error_handler 13 | 14 | val default_error_handler : error_handler 15 | 16 | val to_httpaf_request_handler 17 | : string 18 | -> App.t 19 | -> Httpaf.Server_connection.request_handler 20 | 21 | (** The Halt exception can be raised to interrupt the normal processing flow of a request. 22 | 23 | The exception will be handled by the main run function (in {!Server_connection.run}) 24 | and the response will be sent to the client directly. 25 | 26 | This is especially useful when you want to make sure that no other middleware will be 27 | able to modify the response. *) 28 | exception Halt of Response.t 29 | 30 | (** Raises a Halt exception to interrupt the processing of the connection and trigger an 31 | early response. *) 32 | val halt : Response.t -> 'a 33 | -------------------------------------------------------------------------------- /rock/src/service.ml: -------------------------------------------------------------------------------- 1 | type ('req, 'res) t = 'req -> 'res Lwt.t 2 | -------------------------------------------------------------------------------- /rock/src/service.mli: -------------------------------------------------------------------------------- 1 | (** A service is a function that returns its result asynchronously. *) 2 | 3 | type ('req, 'rep) t = 'req -> 'rep Lwt.t 4 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | let 3 | ocamlPackages = pkgs.ocaml-ng.ocamlPackages_4_13; 4 | local = pkgs.callPackage ./. { inherit ocamlPackages; }; 5 | in 6 | pkgs.mkShell { 7 | inputsFrom = with local; [ rock opium opium-testing opium-graphql ]; 8 | buildInputs = [ ocamlPackages.ocaml-lsp pkgs.ocamlformat ]; 9 | } 10 | --------------------------------------------------------------------------------