├── .gitignore
├── .ocamlformat
├── .ocp-indent
├── .travis.yml
├── CHANGES
├── LICENSE.md
├── META.websocket.template
├── Makefile
├── README.md
├── RELEASE.md
├── core
    ├── dune
    ├── sha1.ml
    ├── websocket.ml
    └── websocket.mli
├── dune-project
├── lwt
    ├── dune
    ├── websocket_cohttp_lwt.ml
    ├── websocket_cohttp_lwt.mli
    ├── websocket_lwt_unix.ml
    ├── websocket_lwt_unix.mli
    └── wscat.ml
├── test
    ├── dune
    ├── reynir.ml
    └── upgrade_connection.ml
├── websocket-lwt-unix.opam
└── websocket.opam


/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | **/*.merlin
3 | *.install
4 | _opam


--------------------------------------------------------------------------------
/.ocamlformat:
--------------------------------------------------------------------------------
1 | profile = default
2 | break-separators = after
3 | 


--------------------------------------------------------------------------------
/.ocp-indent:
--------------------------------------------------------------------------------
1 | strict_with=always,match_clause=2,strict_else=never
2 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | language: c
 2 | sudo: required
 3 | install: test -e .travis.opam.sh || wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
 4 | script:
 5 | - bash -ex .travis-opam.sh
 6 | env:
 7 |   matrix:
 8 |     - OCAML_VERSION="4.09" PACKAGE="websocket"
 9 |     - OCAML_VERSION="4.09" PACKAGE="websocket-lwt-unix"
10 |     - OCAML_VERSION="4.09" PACKAGE="websocket-async"
11 | os:
12 | - linux
13 | 


--------------------------------------------------------------------------------
/CHANGES:
--------------------------------------------------------------------------------
  1 | 2.17 (2024-09-07) Nancy
  2 | -----------------------
  3 | 
  4 | - adapt to mirage-crypto (@copy)
  5 | - use mirage-crypto-rng as csprng (@ushitora-anqou)
  6 | 
  7 | 2.16 (2023-01-02) Nancy
  8 | -----------------------
  9 | 
 10 | - flush output after writing frames
 11 | - ocamlformat: use default profile
 12 | - async: Adapt to Core/Async v0.15
 13 | 
 14 | 2.15 (2021-03-16) Nancy
 15 | -----------------------
 16 | 
 17 | - Lwt (interface): abstract conn type (@paurkedal)
 18 | - Lwt (name change): with_connection -> connect
 19 | - Cohttp: adapt to new version (@kit-ty-kate)
 20 | - Conduit: adapt to new version (@MisterDA)
 21 | 
 22 | 2.14 (2020-03-5) Paris
 23 | ----------------------
 24 | 
 25 | - bugfix: cohttp_lwt: call conn_closed on fd close (@NightBlues)
 26 | - fix compilation with newer async (@copy)
 27 | - fix compilation with newer conduit (@tizoc)
 28 | 
 29 | 2.13 (2019-03-17)
 30 | -----------------
 31 | 
 32 | - Async: use logs_async
 33 | - Async: upgrade_connection API (@kkazuo)
 34 | - Lwt: fix upgrade_connection for TLS (API change)
 35 | - Upgrade Base64 support to 3.1.0
 36 | 
 37 | 2.12 (2018-10-01)
 38 | -----------------
 39 | 
 40 | - build: switch to `dune`
 41 | 
 42 | 2.11 (2017-12-19)
 43 | -----------------
 44 | 
 45 | - Lwt: fix compilation for Cohttp_lwt_unix >= 1.0
 46 | 
 47 | 2.10 (2017-08-01)
 48 | -----------------
 49 | 
 50 | - Build: use jbuilder
 51 | - Lwt: add `check_origin` (@zoggy)
 52 | - Lwt: add `send_multiple` (@copy)
 53 | 
 54 | 2.9 (2017-03-20)
 55 | -----------------
 56 | 
 57 | - Lwt: rename ?exception_handler to ?on_exn, to match Conduit
 58 | - Async: Add ?check_request with the same interface as Lwt backend
 59 | - Fix compilation with the dev version of Async
 60 | 
 61 | 2.8 (2017-03-01)
 62 | ----------------
 63 | 
 64 | - drop dependency to ppx_deriving
 65 | - bugfix: fix corrupted received frame (@zoggy)
 66 | 
 67 | 2.7 (2017-02-21)
 68 | ----------------
 69 | 
 70 | - new websocket.cohttp package to upgrade to websocket from cohttp (@SimonJF)
 71 | - lwt: function `source' now covers all conduit cases
 72 | - async: refactoring and fixes
 73 | - perf improvement (Avoid generating xor mask if it isn't used) (@copy)
 74 | - remove dependency to containers library
 75 | - lwt: Add callback to check origin before websocket connection (@copy)
 76 | - lwt: Improve error handling in lwt server (@copy)
 77 | - async: more efficient logging
 78 | 
 79 | 2.6 (2016-09-17)
 80 | ----------------
 81 | 
 82 | - async: client_ez: kill the connection on absence of PONG reply
 83 | - async: client_ez: fix PONG watch code
 84 | - websocket: use read_exactly (@copy)
 85 | 
 86 | 2.5 (2016-08-16)
 87 | ----------------
 88 | 
 89 | - async: client_ez: add an ?opcode argument
 90 | - lwt: unset async_exception_hook (@copy)
 91 | 
 92 | 2.4 (2016-07-26)
 93 | ----------------
 94 | 
 95 | - bugfix: Handle truncated cohttp stream reads (@kayceesrk)
 96 | - cleanup: Async version does not depend on containers anymore
 97 | - build: fix META generation, fixing Async-only installation
 98 | 
 99 | 2.3 (2016-06-29)
100 | ----------------
101 | 
102 | - async: bugfix: fix fd leak that occurred when pipes were not closed
103 | - async: log, name as optional args in functions
104 | - lwt server: support from connection upgrade (@lostman)
105 | - bugfix: fix reading int64 encoded frame size
106 | - async server: bugfixes and interface improvement (@copy)
107 | - parametrize random string generation (@j0sh)
108 | - async client: minor improvements
109 | 
110 | 2.2 (2015-12-23)
111 | ----------------
112 | 
113 | - Async backend
114 | - Code refactoring, bugfixes and upgrade to new version of libraries
115 | 
116 | 2.1 (2015-07-07)
117 | ----------------
118 | 
119 | - server: Pass in a Cohttp.Request.t instead of Uri.t
120 | - add Websocket_Lwt.{mk_frame_stream,establish_standard_server}
121 | - websocket_lwt.cm{a,xa} now only contains module Websocket_lwt
122 | - Fix upgrade, keepalive issue with Firefox regression
123 | - Websocket_lwt: Use entropy generator
124 | 
125 | 2.0.0 (2015-06-18)
126 | ------------------
127 | 
128 | - Breaking API change: not Lwt_stream based anymore
129 | - Switch to conduit (TLS)
130 | - Functorisation of common code, new Websocket_lwt module
131 | - More RFC compliance using Autobahn Test Suite
132 | - Bugfixes
133 | 
134 | 0.9.3 (2015-03-23)
135 | ------------------
136 | 
137 | - Support TLS 0.4.0+ API.
138 | 
139 | 0.9.2 (2015-02-10)
140 | ------------------
141 | 
142 | - Bugfix: Do not verify result of setsockopt
143 | 
144 | 0.9.1 (2015-01-03)
145 | ------------------
146 | 
147 | - safe_string
148 | - fix a critical bug that when handling masked frames
149 | 
150 | 0.9 (2014-08-21)
151 | ----------------
152 | 
153 | - Drop support for OCaml < 4
154 | - Replace Cryptokit by Nocrypto
155 | - Replace Lwt_ssl by Tls_lwt for TLS
156 | - Add TLS support for the websocket server
157 | - Replace OASIS by topkg
158 | - Removing camlp4
159 | - Minor interface changes
160 | 
161 | 0.8.2 (2014-06-09)
162 | ------------------
163 | 
164 | - [doc] Add a warning in the doc of `establish_server`
165 | - Close frame now contain a status code (TODO: expose it somewhere)
166 | - Fix fd leakages (hopefully the library should not leak any fds anymore)
167 | - Use OASIS' compiled_setup_ml feature
168 | 
169 | 0.8.1 (2014-03-26)
170 | ------------------
171 | 
172 | - Upgrade to OASIS 0.4
173 | 
174 | 0.8 (2014-03-26)
175 | ----------------
176 | 
177 | - decode connection upgrade header with regex
178 | 
179 | 0.7 (2014-03-02)
180 | ----------------
181 | 
182 | - New "extra_headers" optional argument for {open,with}_connection (acm)
183 | - Port to cohttp 0.10.x API (avsm)
184 | 
185 | 0.6 (2013-08-20)
186 | ----------------
187 | 
188 | - Added SSL support for the client.
189 | 
190 | 0.5 (2013-05-06)
191 | ----------------
192 | 
193 | - First working release.
194 | 


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2016 Vincent Bernardoff
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/META.websocket.template:
--------------------------------------------------------------------------------
 1 | # JBUILDER_GEN
 2 | 
 3 | package "lwt" (
 4 |   description = "Deprecated. Use websocket-lwt directly"
 5 |   requires = "websocket-lwt"
 6 | )
 7 | 
 8 | package "async" (
 9 |   description = "Deprecated. Use websocket-async directly"
10 |   requires = "websocket-async"
11 | )
12 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | all:
2 | 	dune build @all
3 | 
4 | clean:
5 | 	dune clean
6 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | ocaml-websocket — Websocket library for OCaml
 2 | ---------------------------------------------
 3 | 
 4 | The WebSocket Protocol enables two-way communication between a client
 5 | running untrusted code in a controlled environment to a remote host
 6 | that has opted-in to communications from that code.
 7 | 
 8 | The security model used for this is the origin-based security model
 9 | commonly used by web browsers. The protocol consists of an opening
10 | handshake followed by basic message framing, layered over TCP.
11 | 
12 | The goal of this technology is to provide a mechanism for
13 | browser-based applications that need two-way communication with
14 | servers that does not rely on opening multiple HTTP connections (e.g.,
15 | using XMLHttpRequest or <iframe>s and long polling).
16 | 
17 | ## Installation
18 | 
19 | ocaml-websocket can be installed with `opam`:
20 | 
21 | ```
22 | opam install websocket
23 | ```
24 | 
25 | If you don't use `opam` please consult the `websocket.opam`,
26 | `websocket-lwt.opam` and `websocket-async.opam` files for build
27 | instructions.


--------------------------------------------------------------------------------
/RELEASE.md:
--------------------------------------------------------------------------------
1 | * change version number in opam
2 | * change version number in pkg/build
3 | * edit CHANGES
4 | * add a tag


--------------------------------------------------------------------------------
/core/dune:
--------------------------------------------------------------------------------
1 | (library
2 |  (name websocket)
3 |  (public_name websocket)
4 |  (modules sha1 websocket)
5 |  (libraries astring base64 ocplib-endian conduit cohttp mirage-crypto-rng))
6 | 


--------------------------------------------------------------------------------
/core/sha1.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2008 Daniel C. Bünzli. All rights reserved.
  3 |    Distributed under a BSD3 license, see license at the end of the file.
  4 |    %%NAME%% release %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | (* sha-1 digest. Based on pseudo-code of RFC 3174.
  8 |    Slow and ugly but does the job. Based on the SHA1 in Uuidm. *)
  9 | let sha_1 (s : string) : string =
 10 |   let sha_1_pad s =
 11 |     let len = String.length s in
 12 |     let blen = 8 * len in
 13 |     let rem = len mod 64 in
 14 |     let mlen = if rem > 55 then len + 128 - rem else len + 64 - rem in
 15 |     let m = Bytes.create mlen in
 16 |     Bytes.blit_string s 0 m 0 len;
 17 |     Bytes.fill m len (mlen - len) '\x00';
 18 |     Bytes.set m len '\x80';
 19 |     if Sys.word_size > 32 then (
 20 |       Bytes.set m (mlen - 8) (Char.unsafe_chr ((blen lsr 56) land 0xFF));
 21 |       Bytes.set m (mlen - 7) (Char.unsafe_chr ((blen lsr 48) land 0xFF));
 22 |       Bytes.set m (mlen - 6) (Char.unsafe_chr ((blen lsr 40) land 0xFF));
 23 |       Bytes.set m (mlen - 5) (Char.unsafe_chr ((blen lsr 32) land 0xFF)));
 24 |     Bytes.set m (mlen - 4) (Char.unsafe_chr ((blen lsr 24) land 0xFF));
 25 |     Bytes.set m (mlen - 3) (Char.unsafe_chr ((blen lsr 16) land 0xFF));
 26 |     Bytes.set m (mlen - 2) (Char.unsafe_chr ((blen lsr 8) land 0xFF));
 27 |     Bytes.set m (mlen - 1) (Char.unsafe_chr (blen land 0xFF));
 28 |     m
 29 |   in
 30 |   (* Operations on int32 *)
 31 |   let ( &&& ) = ( land ) in
 32 |   let ( lor ) = Int32.logor in
 33 |   let ( lxor ) = Int32.logxor in
 34 |   let ( land ) = Int32.logand in
 35 |   let ( ++ ) = Int32.add in
 36 |   let lnot = Int32.lognot in
 37 |   let sr = Int32.shift_right in
 38 |   let sl = Int32.shift_left in
 39 |   let cls n x = sl x n lor Int32.shift_right_logical x (32 - n) in
 40 |   (* Start *)
 41 |   let m = sha_1_pad s in
 42 |   let w = Array.make 16 0l in
 43 |   let h0 = ref 0x67452301l in
 44 |   let h1 = ref 0xEFCDAB89l in
 45 |   let h2 = ref 0x98BADCFEl in
 46 |   let h3 = ref 0x10325476l in
 47 |   let h4 = ref 0xC3D2E1F0l in
 48 |   let a = ref 0l in
 49 |   let b = ref 0l in
 50 |   let c = ref 0l in
 51 |   let d = ref 0l in
 52 |   let e = ref 0l in
 53 |   for i = 0 to (Bytes.length m / 64) - 1 do
 54 |     (* For each block *)
 55 |     (* Fill w *)
 56 |     let base = i * 64 in
 57 |     for j = 0 to 15 do
 58 |       let k = base + (j * 4) in
 59 |       w.(j) <-
 60 |         sl (Int32.of_int (Char.code (Bytes.get m k))) 24
 61 |         lor sl (Int32.of_int (Char.code (Bytes.get m (k + 1)))) 16
 62 |         lor sl (Int32.of_int (Char.code (Bytes.get m (k + 2)))) 8
 63 |         lor Int32.of_int (Char.code (Bytes.get m (k + 3)))
 64 |     done;
 65 |     (* Loop *)
 66 |     a := !h0;
 67 |     b := !h1;
 68 |     c := !h2;
 69 |     d := !h3;
 70 |     e := !h4;
 71 |     for t = 0 to 79 do
 72 |       let f, k =
 73 |         if t <= 19 then (!b land !c lor (lnot !b land !d), 0x5A827999l)
 74 |         else if t <= 39 then (!b lxor !c lxor !d, 0x6ED9EBA1l)
 75 |         else if t <= 59 then
 76 |           (!b land !c lor (!b land !d) lor (!c land !d), 0x8F1BBCDCl)
 77 |         else (!b lxor !c lxor !d, 0xCA62C1D6l)
 78 |       in
 79 |       let s = t &&& 0xF in
 80 |       if t >= 16 then
 81 |         w.(s) <-
 82 |           cls 1
 83 |             (w.(s + 13 &&& 0xF)
 84 |             lxor w.(s + 8 &&& 0xF)
 85 |             lxor w.(s + 2 &&& 0xF)
 86 |             lxor w.(s));
 87 |       let temp = cls 5 !a ++ f ++ !e ++ w.(s) ++ k in
 88 |       e := !d;
 89 |       d := !c;
 90 |       c := cls 30 !b;
 91 |       b := !a;
 92 |       a := temp
 93 |     done;
 94 |     (* Update *)
 95 |     h0 := !h0 ++ !a;
 96 |     h1 := !h1 ++ !b;
 97 |     h2 := !h2 ++ !c;
 98 |     h3 := !h3 ++ !d;
 99 |     h4 := !h4 ++ !e
100 |   done;
101 |   let h = Bytes.create 20 in
102 |   let i2s h k i =
103 |     Bytes.set h k (Char.unsafe_chr (Int32.to_int (sr i 24) &&& 0xFF));
104 |     Bytes.set h (k + 1) (Char.unsafe_chr (Int32.to_int (sr i 16) &&& 0xFF));
105 |     Bytes.set h (k + 2) (Char.unsafe_chr (Int32.to_int (sr i 8) &&& 0xFF));
106 |     Bytes.set h (k + 3) (Char.unsafe_chr (Int32.to_int i &&& 0xFF))
107 |   in
108 |   i2s h 0 !h0;
109 |   i2s h 4 !h1;
110 |   i2s h 8 !h2;
111 |   i2s h 12 !h3;
112 |   i2s h 16 !h4;
113 |   Bytes.unsafe_to_string h
114 | 
115 | (*---------------------------------------------------------------------------
116 |   Copyright (c) 2008 Daniel C. Bünzli
117 |   All rights reserved.
118 | 
119 |   Redistribution and use in source and binary forms, with or without
120 |   modification, are permitted provided that the following conditions are
121 |   met:
122 | 
123 |   1. Redistributions of source code must retain the above copyright
124 |      notice, this list of conditions and the following disclaimer.
125 | 
126 |   2. Redistributions in binary form must reproduce the above copyright
127 |      notice, this list of conditions and the following disclaimer in the
128 |      documentation and/or other materials provided with the
129 |      distribution.
130 | 
131 |   3. Neither the name of Daniel C. Bünzli nor the names of
132 |      contributors may be used to endorse or promote products derived
133 |      from this software without specific prior written permission.
134 | 
135 |   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
136 |   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
137 |   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
138 |   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
139 |   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
140 |   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
141 |   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
142 |   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
143 |   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
144 |   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
145 |   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
146 |   ---------------------------------------------------------------------------*)
147 | 


--------------------------------------------------------------------------------
/core/websocket.ml:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
  3 |  *
  4 |  * Permission to use, copy, modify, and distribute this software for any
  5 |  * purpose with or without fee is hereby granted, provided that the above
  6 |  * copyright notice and this permission notice appear in all copies.
  7 |  *
  8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 15 |  *
 16 |  *)
 17 | 
 18 | open Astring
 19 | 
 20 | let b64_encoded_sha1sum s = Base64.encode_exn (Sha1.sha_1 s)
 21 | let websocket_uuid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
 22 | 
 23 | module Rng = struct
 24 |   let init () len = Mirage_crypto_rng.generate len
 25 | end
 26 | 
 27 | module Frame = struct
 28 |   module Opcode = struct
 29 |     type t =
 30 |       | Continuation
 31 |       | Text
 32 |       | Binary
 33 |       | Close
 34 |       | Ping
 35 |       | Pong
 36 |       | Ctrl of int
 37 |       | Nonctrl of int
 38 | 
 39 |     let to_string = function
 40 |       | Continuation -> "continuation"
 41 |       | Text -> "text"
 42 |       | Binary -> "binary"
 43 |       | Close -> "close"
 44 |       | Ping -> "ping"
 45 |       | Pong -> "pong"
 46 |       | Ctrl i -> "ctrl " ^ string_of_int i
 47 |       | Nonctrl i -> "nonctrl " ^ string_of_int i
 48 | 
 49 |     let pp ppf t = Format.fprintf ppf "%s" (to_string t)
 50 | 
 51 |     let of_enum = function
 52 |       | i when i < 0 || i > 0xf -> invalid_arg "Frame.Opcode.of_enum"
 53 |       | 0 -> Continuation
 54 |       | 1 -> Text
 55 |       | 2 -> Binary
 56 |       | 8 -> Close
 57 |       | 9 -> Ping
 58 |       | 10 -> Pong
 59 |       | i when i < 8 -> Nonctrl i
 60 |       | i -> Ctrl i
 61 | 
 62 |     let to_enum = function
 63 |       | Continuation -> 0
 64 |       | Text -> 1
 65 |       | Binary -> 2
 66 |       | Close -> 8
 67 |       | Ping -> 9
 68 |       | Pong -> 10
 69 |       | Ctrl i -> i
 70 |       | Nonctrl i -> i
 71 | 
 72 |     let is_ctrl opcode = to_enum opcode > 7
 73 |   end
 74 | 
 75 |   type t = {
 76 |     opcode : Opcode.t;
 77 |     extension : int;
 78 |     final : bool;
 79 |     content : string;
 80 |   }
 81 | 
 82 |   let pp ppf { opcode; extension; final; content } =
 83 |     Format.fprintf ppf "[%a (0x%x) (final=%b) %s]" Opcode.pp opcode extension
 84 |       final content
 85 | 
 86 |   let show t = Format.asprintf "%a" pp t
 87 | 
 88 |   let create ?(opcode = Opcode.Text) ?(extension = 0) ?(final = true)
 89 |       ?(content = "") () =
 90 |     { opcode; extension; final; content }
 91 | 
 92 |   let of_bytes ?opcode ?extension ?final content =
 93 |     let content = Bytes.to_string content in
 94 |     create ?opcode ?extension ?final ~content ()
 95 | 
 96 |   let close code =
 97 |     let content = Bytes.create 2 in
 98 |     EndianBytes.BigEndian.set_int16 content 0 code;
 99 |     of_bytes ~opcode:Opcode.Close content
100 | end
101 | 
102 | let xor mask msg =
103 |   for i = 0 to Bytes.length msg - 1 do
104 |     (* masking msg to send *)
105 |     Bytes.set msg i
106 |       Char.(to_int mask.[i mod 4] lxor to_int (Bytes.get msg i) |> of_byte)
107 |   done
108 | 
109 | let is_bit_set idx v = (v lsr idx) land 1 = 1
110 | let set_bit v idx b = if b then v lor (1 lsl idx) else v land lnot (1 lsl idx)
111 | let int_value shift len v = (v lsr shift) land ((1 lsl len) - 1)
112 | 
113 | let upgrade_present hs =
114 |   Cohttp.Header.get_multi hs "connection" |> fun hs ->
115 |   List.map (String.cuts ~sep:",") hs |> fun hs ->
116 |   List.flatten hs |> fun hs ->
117 |   List.map String.(fun h -> h |> String.Ascii.lowercase |> trim) hs
118 |   |> List.mem "upgrade"
119 | 
120 | exception Protocol_error of string
121 | 
122 | let proto_error x = Format.kasprintf (fun x -> raise (Protocol_error x)) x
123 | 
124 | let check_origin ?(origin_mandatory = false) ~hosts =
125 |   let pred origin_host =
126 |     List.exists (fun h -> String.Ascii.lowercase h = origin_host) hosts
127 |   in
128 |   fun request ->
129 |     let headers = request.Cohttp.Request.headers in
130 |     match Cohttp.Header.get headers "origin" with
131 |     | None -> not origin_mandatory
132 |     | Some origin -> (
133 |         let origin = Uri.of_string origin in
134 |         match Uri.host origin with
135 |         | None -> false
136 |         | Some host ->
137 |             (* host is already lowercased by Uri *)
138 |             pred host)
139 | 
140 | let check_origin_with_host request =
141 |   let headers = request.Cohttp.Request.headers in
142 |   let host = Cohttp.Header.get headers "host" in
143 |   match host with
144 |   | None -> failwith "Missing host header" (* mandatory in http/1.1 *)
145 |   | Some host ->
146 |       (* remove port *)
147 |       let hostname =
148 |         match String.cut ~sep:":" host with None -> host | Some (h, _) -> h
149 |       in
150 |       check_origin ~hosts:[ hostname ] request
151 | 
152 | module type S = sig
153 |   module IO : Cohttp.S.IO
154 | 
155 |   type mode = Client of (int -> string) | Server
156 | 
157 |   val make_read_frame :
158 |     ?buf:Buffer.t -> mode:mode -> IO.ic -> IO.oc -> unit -> Frame.t IO.t
159 | 
160 |   val write_frame_to_buf : mode:mode -> Buffer.t -> Frame.t -> unit
161 | 
162 |   module Request :
163 |     Cohttp.S.Http_io
164 |       with type t = Cohttp.Request.t
165 |        and type 'a IO.t = 'a IO.t
166 |        and type IO.ic = IO.ic
167 |        and type IO.oc = IO.oc
168 | 
169 |   module Response :
170 |     Cohttp.S.Http_io
171 |       with type t = Cohttp.Response.t
172 |        and type 'a IO.t = 'a IO.t
173 |        and type IO.ic = IO.ic
174 |        and type IO.oc = IO.oc
175 | 
176 |   module Connected_client : sig
177 |     type t
178 | 
179 |     val create :
180 |       ?read_buf:Buffer.t ->
181 |       ?write_buf:Buffer.t ->
182 |       Cohttp.Request.t ->
183 |       IO.ic ->
184 |       IO.oc ->
185 |       t
186 | 
187 |     val make_standard : t -> t
188 |     val send : t -> Frame.t -> unit IO.t
189 |     val send_multiple : t -> Frame.t list -> unit IO.t
190 |     val recv : t -> Frame.t IO.t
191 |     val http_request : t -> Cohttp.Request.t
192 |   end
193 | end
194 | 
195 | module Make (IO : Cohttp.S.IO) = struct
196 |   open IO
197 |   module IO = IO
198 | 
199 |   type mode = Client of (int -> string) | Server
200 | 
201 |   let is_client mode = mode <> Server
202 | 
203 |   let rec read_exactly ic remaining buf =
204 |     read ic remaining >>= function
205 |     | "" -> return None
206 |     | s ->
207 |         let recv_len = String.length s in
208 |         Buffer.add_string buf s;
209 |         if remaining - recv_len <= 0 then return @@ Some (Buffer.contents buf)
210 |         else read_exactly ic (remaining - recv_len) buf
211 | 
212 |   let read_uint16 ic buf =
213 |     read_exactly ic 2 buf >>= fun s ->
214 |     match s with
215 |     | None -> return None
216 |     | Some s -> return @@ Some (EndianString.BigEndian.get_uint16 s 0)
217 | 
218 |   let read_int64 ic buf =
219 |     read_exactly ic 8 buf >>= fun s ->
220 |     match s with
221 |     | None -> return None
222 |     | Some s ->
223 |         return @@ Some (Int64.to_int @@ EndianString.BigEndian.get_int64 s 0)
224 | 
225 |   let write_frame_to_buf ~mode buf fr =
226 |     let scratch = Bytes.create 8 in
227 |     let open Frame in
228 |     let content = Bytes.of_string fr.content in
229 |     let len = Bytes.length content in
230 |     let opcode = Opcode.to_enum fr.opcode in
231 |     let payload_len =
232 |       match len with
233 |       | n when n < 126 -> len
234 |       | n when n < 1 lsl 16 -> 126
235 |       | _ -> 127
236 |     in
237 |     let hdr = set_bit 0 15 fr.final in
238 |     (* We do not support extensions for now *)
239 |     let hdr = hdr lor (opcode lsl 8) in
240 |     let hdr = set_bit hdr 7 (is_client mode) in
241 |     let hdr = hdr lor payload_len in
242 |     (* Payload len is guaranteed to fit in 7 bits *)
243 |     EndianBytes.BigEndian.set_int16 scratch 0 hdr;
244 |     Buffer.add_subbytes buf scratch 0 2;
245 |     (match len with
246 |     | n when n < 126 -> ()
247 |     | n when n < 1 lsl 16 ->
248 |         EndianBytes.BigEndian.set_int16 scratch 0 n;
249 |         Buffer.add_subbytes buf scratch 0 2
250 |     | n ->
251 |         EndianBytes.BigEndian.set_int64 scratch 0 Int64.(of_int n);
252 |         Buffer.add_subbytes buf scratch 0 8);
253 |     (match mode with
254 |     | Server -> ()
255 |     | Client random_string ->
256 |         let mask = random_string 4 in
257 |         Buffer.add_string buf mask;
258 |         if len > 0 then xor mask content);
259 |     Buffer.add_bytes buf content
260 | 
261 |   let close_with_code mode buf oc code =
262 |     Buffer.clear buf;
263 |     write_frame_to_buf ~mode buf @@ Frame.close code;
264 |     write oc @@ Buffer.contents buf
265 | 
266 |   let read_frame ic oc buf mode hdr =
267 |     let hdr_part1 = EndianString.BigEndian.get_int8 hdr 0 in
268 |     let hdr_part2 = EndianString.BigEndian.get_int8 hdr 1 in
269 |     let final = is_bit_set 7 hdr_part1 in
270 |     let extension = int_value 4 3 hdr_part1 in
271 |     let opcode = int_value 0 4 hdr_part1 in
272 |     let frame_masked = is_bit_set 7 hdr_part2 in
273 |     let length = int_value 0 7 hdr_part2 in
274 |     let opcode = Frame.Opcode.of_enum opcode in
275 |     Buffer.clear buf;
276 |     (match length with
277 |     | i when i < 126 -> return i
278 |     | 126 -> (
279 |         read_uint16 ic buf >>= function
280 |         | Some i -> return i
281 |         | None -> return @@ -1)
282 |     | 127 -> (
283 |         read_int64 ic buf >>= function
284 |         | Some i -> return i
285 |         | None -> return @@ -1)
286 |     | _ -> return @@ -1)
287 |     >>= fun payload_len ->
288 |     if payload_len = -1 then proto_error "payload len = %d" length
289 |     else if extension <> 0 then
290 |       close_with_code mode buf oc 1002 >>= fun () ->
291 |       proto_error "unsupported extension"
292 |     else if Frame.Opcode.is_ctrl opcode && payload_len > 125 then
293 |       close_with_code mode buf oc 1002 >>= fun () ->
294 |       proto_error "control frame too big"
295 |     else
296 |       (if frame_masked then (
297 |          Buffer.clear buf;
298 |          read_exactly ic 4 buf >>= function
299 |          | None -> proto_error "could not read mask"
300 |          | Some mask -> return mask)
301 |        else return String.empty)
302 |       >>= fun mask ->
303 |       if payload_len = 0 then
304 |         return @@ Frame.create ~opcode ~extension ~final ()
305 |       else (
306 |         Buffer.clear buf;
307 |         read_exactly ic payload_len buf >>= fun payload ->
308 |         match payload with
309 |         | None -> proto_error "could not read payload (len=%d)" payload_len
310 |         | Some payload ->
311 |             let payload = Bytes.of_string payload in
312 |             if frame_masked then xor mask payload;
313 |             let frame = Frame.of_bytes ~opcode ~extension ~final payload in
314 |             return frame)
315 | 
316 |   let make_read_frame ?(buf = Buffer.create 128) ~mode ic oc () =
317 |     Buffer.clear buf;
318 |     read_exactly ic 2 buf >>= function
319 |     | None -> raise End_of_file
320 |     | Some hdr -> read_frame ic oc buf mode hdr
321 | 
322 |   module Request = Cohttp.Request.Private.Make (IO)
323 |   module Response = Cohttp.Response.Private.Make (IO)
324 | 
325 |   module Connected_client = struct
326 |     type t = {
327 |       buffer : Buffer.t;
328 |       ic : Request.IO.ic;
329 |       oc : Request.IO.oc;
330 |       http_request : Cohttp.Request.t;
331 |       standard_frame_replies : bool;
332 |       read_frame : unit -> Frame.t IO.t;
333 |     }
334 | 
335 |     let create ?read_buf ?(write_buf = Buffer.create 128) http_request ic oc =
336 |       let read_frame = make_read_frame ?buf:read_buf ~mode:Server ic oc in
337 |       {
338 |         buffer = write_buf;
339 |         ic;
340 |         oc;
341 |         http_request;
342 |         standard_frame_replies = false;
343 |         read_frame;
344 |       }
345 | 
346 |     let send { buffer; oc; _ } frame =
347 |       Buffer.clear buffer;
348 |       write_frame_to_buf ~mode:Server buffer frame;
349 |       IO.write oc @@ Buffer.contents buffer
350 | 
351 |     let send_multiple { buffer; oc; _ } frames =
352 |       Buffer.clear buffer;
353 |       List.iter (write_frame_to_buf ~mode:Server buffer) frames;
354 |       IO.write oc @@ Buffer.contents buffer
355 | 
356 |     let standard_recv t =
357 |       t.read_frame () >>= fun fr ->
358 |       match fr.Frame.opcode with
359 |       | Frame.Opcode.Ping ->
360 |           send t @@ Frame.create ~opcode:Frame.Opcode.Pong () >>= fun () ->
361 |           return fr
362 |       | Frame.Opcode.Close ->
363 |           (* Immediately echo and pass this last message to the user *)
364 |           (if String.length fr.Frame.content >= 2 then
365 |              send t
366 |              @@ Frame.create ~opcode:Frame.Opcode.Close
367 |                   ~content:
368 |                     String.(
369 |                       sub ~start:0 ~stop:2 fr.Frame.content |> Sub.to_string)
370 |                   ()
371 |            else send t @@ Frame.close 1000)
372 |           >>= fun () -> return fr
373 |       | _ -> return fr
374 | 
375 |     let recv t =
376 |       if t.standard_frame_replies then standard_recv t else t.read_frame ()
377 | 
378 |     let http_request { http_request; _ } = http_request
379 |     let make_standard t = { t with standard_frame_replies = true }
380 |   end
381 | end
382 | 


--------------------------------------------------------------------------------
/core/websocket.mli:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
  3 |  *
  4 |  * Permission to use, copy, modify, and distribute this software for any
  5 |  * purpose with or without fee is hereby granted, provided that the above
  6 |  * copyright notice and this permission notice appear in all copies.
  7 |  *
  8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 15 |  *
 16 |  *)
 17 | 
 18 | val websocket_uuid : string
 19 | val b64_encoded_sha1sum : string -> string
 20 | val upgrade_present : Cohttp.Header.t -> bool
 21 | 
 22 | exception Protocol_error of string
 23 | 
 24 | module Rng : sig
 25 |   val init : unit -> int -> string
 26 |   (** [init ?state ()] is a function that returns a string of random bytes of
 27 |       length equal to its argument. *)
 28 | end
 29 | 
 30 | module Frame : sig
 31 |   module Opcode : sig
 32 |     type t =
 33 |       | Continuation
 34 |       | Text
 35 |       | Binary
 36 |       | Close
 37 |       | Ping
 38 |       | Pong
 39 |       | Ctrl of int
 40 |       | Nonctrl of int
 41 | 
 42 |     val to_string : t -> string
 43 |     val pp : Format.formatter -> t -> unit
 44 |   end
 45 | 
 46 |   type t = {
 47 |     opcode : Opcode.t;
 48 |     extension : int;
 49 |     final : bool;
 50 |     content : string;
 51 |   }
 52 | 
 53 |   val pp : Format.formatter -> t -> unit
 54 |   val show : t -> string
 55 | 
 56 |   val create :
 57 |     ?opcode:Opcode.t ->
 58 |     ?extension:int ->
 59 |     ?final:bool ->
 60 |     ?content:string ->
 61 |     unit ->
 62 |     t
 63 | 
 64 |   val close : int -> t
 65 | end
 66 | 
 67 | val check_origin :
 68 |   ?origin_mandatory:bool -> hosts:string list -> Cohttp.Request.t -> bool
 69 | (** [check_origin ~hosts req] will return [true] if the origin header exists and
 70 |     matches one of the provided hostnames. If origin header is not present,
 71 |     return [not origin_mandatory]. Default value of [origin_mandatory] is false.
 72 |     If origin header is present but does not contain a hostname, return [false].
 73 |     Hostnames in [hosts] are (ascii-)lowercased when compared.*)
 74 | 
 75 | val check_origin_with_host : Cohttp.Request.t -> bool
 76 | (** [check_origin_with_host] returns false if the origin header exists and its
 77 |     host doesn't match the host header *)
 78 | 
 79 | module type S = sig
 80 |   module IO : Cohttp.S.IO
 81 | 
 82 |   type mode = Client of (int -> string) | Server
 83 | 
 84 |   val make_read_frame :
 85 |     ?buf:Buffer.t -> mode:mode -> IO.ic -> IO.oc -> unit -> Frame.t IO.t
 86 | 
 87 |   val write_frame_to_buf : mode:mode -> Buffer.t -> Frame.t -> unit
 88 | 
 89 |   module Request :
 90 |     Cohttp.S.Http_io
 91 |       with type t = Cohttp.Request.t
 92 |        and type 'a IO.t = 'a IO.t
 93 |        and type IO.ic = IO.ic
 94 |        and type IO.oc = IO.oc
 95 | 
 96 |   module Response :
 97 |     Cohttp.S.Http_io
 98 |       with type t = Cohttp.Response.t
 99 |        and type 'a IO.t = 'a IO.t
100 |        and type IO.ic = IO.ic
101 |        and type IO.oc = IO.oc
102 | 
103 |   module Connected_client : sig
104 |     type t
105 | 
106 |     val create :
107 |       ?read_buf:Buffer.t ->
108 |       ?write_buf:Buffer.t ->
109 |       Cohttp.Request.t ->
110 |       IO.ic ->
111 |       IO.oc ->
112 |       t
113 | 
114 |     val make_standard : t -> t
115 |     val send : t -> Frame.t -> unit IO.t
116 |     val send_multiple : t -> Frame.t list -> unit IO.t
117 |     val recv : t -> Frame.t IO.t
118 |     val http_request : t -> Cohttp.Request.t
119 |   end
120 | end
121 | 
122 | module Make (IO : Cohttp.S.IO) :
123 |   S with type 'a IO.t = 'a IO.t and type IO.ic = IO.ic and type IO.oc = IO.oc
124 | 


--------------------------------------------------------------------------------
/dune-project:
--------------------------------------------------------------------------------
 1 | (lang dune 2.9)
 2 | (name websocket)
 3 | 
 4 | (generate_opam_files true)
 5 | 
 6 | (source (github vbmithr/ocaml-websocket))
 7 | (license ISC)
 8 | (authors "Vincent Bernardoff <vb@luminar.eu.org>")
 9 | (maintainers "Vincent Bernardoff <vb@luminar.eu.org>")
10 | (documentation https://vbmithr.github.io/ocaml-websocket/doc)
11 | 
12 | (package
13 |  (name websocket)
14 |  (synopsis "Websocket library")
15 |  (description
16 | "\| The WebSocket Protocol enables two-way communication between a client
17 | "\| running untrusted code in a controlled environment to a remote host
18 | "\| that has opted-in to communications from that code.
19 | "\|
20 | "\| The security model used for this is the origin-based security model
21 | "\| commonly used by web browsers. The protocol consists of an opening
22 | "\| handshake followed by basic message framing, layered over TCP.
23 | "\|
24 | "\| The goal of this technology is to provide a mechanism for
25 | "\| browser-based applications that need two-way communication with
26 | "\| servers that does not rely on opening multiple HTTP connections (e.g.,
27 | "\| using XMLHttpRequest or <iframe>s and long polling).
28 | )
29 |  (tags (org:mirage org:xapi-project))
30 |  (depends
31 |   (ocaml (>= 4.06.0))
32 |   (base64 (>= 3.3.0))
33 |   (conduit (>= 5.1.0))
34 |   (cohttp (>= 5.0.0))
35 |   (ocplib-endian (>= 1.0))
36 |   (astring (>= 0.8.3))
37 |   (mirage-crypto-rng (>= 1.0.0))))
38 | 
39 | (package
40 |  (name websocket-lwt-unix)
41 |  (synopsis "Websocket library (Lwt)")
42 |  (description
43 | "\| The WebSocket Protocol enables two-way communication between a client
44 | "\| running untrusted code in a controlled environment to a remote host
45 | "\| that has opted-in to communications from that code.
46 | "\|
47 | "\| The security model used for this is the origin-based security model
48 | "\| commonly used by web browsers. The protocol consists of an opening
49 | "\| handshake followed by basic message framing, layered over TCP.
50 | "\|
51 | "\| The goal of this technology is to provide a mechanism for
52 | "\| browser-based applications that need two-way communication with
53 | "\| servers that does not rely on opening multiple HTTP connections (e.g.,
54 | "\| using XMLHttpRequest or <iframe>s and long polling).
55 | )
56 |  (tags (org:mirage org:xapi-project))
57 |  (depends
58 |   (ocaml (>= 4.06.0))
59 |   (websocket (= :version))
60 |   (logs (>= 0.8.0))
61 |   (cohttp-lwt-unix (>= 5.0.0))))
62 | 


--------------------------------------------------------------------------------
/lwt/dune:
--------------------------------------------------------------------------------
 1 | (library
 2 |  (name websocket_lwt_unix)
 3 |  (public_name websocket-lwt-unix)
 4 |  (modules websocket_lwt_unix)
 5 |  (optional)
 6 |  (libraries logs cohttp-lwt-unix websocket))
 7 | 
 8 | (library
 9 |  (name websocket_cohttp_lwt)
10 |  (public_name websocket-lwt-unix.cohttp)
11 |  (modules websocket_cohttp_lwt)
12 |  (optional)
13 |  (libraries websocket cohttp-lwt-unix))
14 | 
15 | (executable
16 |  (name wscat)
17 |  (public_name wscat-lwt)
18 |  (package websocket-lwt-unix)
19 |  (modules wscat)
20 |  (libraries conduit-lwt-unix websocket-lwt-unix sexplib))
21 | 


--------------------------------------------------------------------------------
/lwt/websocket_cohttp_lwt.ml:
--------------------------------------------------------------------------------
 1 | (*
 2 |  * Copyright (c) 2016-2018 Maciej Wos <maciej.wos@gmail.com>
 3 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
 4 |  *
 5 |  * Permission to use, copy, modify, and distribute this software for any
 6 |  * purpose with or without fee is hereby granted, provided that the above
 7 |  * copyright notice and this permission notice appear in all copies.
 8 |  *
 9 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16 |  *
17 |  *)
18 | 
19 | open Lwt.Infix
20 | open Websocket
21 | module Lwt_IO = Websocket.Make (Cohttp_lwt_unix.Private.IO)
22 | 
23 | let send_frames stream oc =
24 |   let buf = Buffer.create 128 in
25 |   let send_frame fr =
26 |     Buffer.clear buf;
27 |     Lwt_IO.write_frame_to_buf ~mode:Server buf fr;
28 |     Lwt_io.write oc @@ Buffer.contents buf
29 |   in
30 |   Lwt_stream.iter_s send_frame stream
31 | 
32 | let read_frames ic oc handler_fn =
33 |   let read_frame = Lwt_IO.make_read_frame ~mode:Server ic oc in
34 |   let rec inner () = read_frame () >>= Lwt.wrap1 handler_fn >>= inner in
35 |   inner ()
36 | 
37 | let upgrade_connection request incoming_handler =
38 |   let headers = Cohttp.Request.headers request in
39 |   (match Cohttp.Header.get headers "sec-websocket-key" with
40 |   | None ->
41 |       Lwt.fail_invalid_arg
42 |         "upgrade_connection: missing header `sec-websocket-key`"
43 |   | Some key -> Lwt.return key)
44 |   >>= fun key ->
45 |   let hash = b64_encoded_sha1sum (key ^ websocket_uuid) in
46 |   let response_headers =
47 |     Cohttp.Header.of_list
48 |       [
49 |         ("Upgrade", "websocket");
50 |         ("Connection", "Upgrade");
51 |         ("Sec-WebSocket-Accept", hash);
52 |       ]
53 |   in
54 |   let resp =
55 |     Cohttp.Response.make ~status:`Switching_protocols
56 |       ~encoding:Cohttp.Transfer.Unknown ~headers:response_headers ()
57 |   in
58 |   let frames_out_stream, frames_out_fn = Lwt_stream.create () in
59 |   let f ic oc =
60 |     Lwt.pick
61 |       [
62 |         (* input: data from the client is read from the input channel
63 |          * of the tcp connection; pass it to handler function *)
64 |         read_frames ic oc incoming_handler;
65 |         (* output: data for the client is written to the output
66 |          * channel of the tcp connection *)
67 |         send_frames frames_out_stream oc;
68 |       ]
69 |   in
70 |   Lwt.return (`Expert (resp, f), frames_out_fn)
71 | 


--------------------------------------------------------------------------------
/lwt/websocket_cohttp_lwt.mli:
--------------------------------------------------------------------------------
 1 | (*
 2 |  * Copyright (c) 2016-2018 Maciej Wos <maciej.wos@gmail.com>
 3 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
 4 |  *
 5 |  * Permission to use, copy, modify, and distribute this software for any
 6 |  * purpose with or without fee is hereby granted, provided that the above
 7 |  * copyright notice and this permission notice appear in all copies.
 8 |  *
 9 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16 |  *
17 |  *)
18 | 
19 | open Websocket
20 | 
21 | val upgrade_connection :
22 |   Cohttp.Request.t ->
23 |   (Frame.t -> unit) ->
24 |   (Cohttp_lwt_unix.Server.response_action * (Frame.t option -> unit)) Lwt.t
25 | (** [upgrade_connection req incoming_handler] takes [req], a
26 |     connection request, and [incoming_handler], a function that will
27 |     process incoming websocket frames, and returns ([response_action],
28 |     [push_frame]) where [response_action] is used to produce a
29 |     {!Cohttp_lwt.Server.t} and [push_frame] is used to send websocket
30 |     frames to the client. *)
31 | 


--------------------------------------------------------------------------------
/lwt/websocket_lwt_unix.ml:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
  3 |  *
  4 |  * Permission to use, copy, modify, and distribute this software for any
  5 |  * purpose with or without fee is hereby granted, provided that the above
  6 |  * copyright notice and this permission notice appear in all copies.
  7 |  *
  8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 15 |  *
 16 |  *)
 17 | 
 18 | open Astring
 19 | open Websocket
 20 | open Lwt.Infix
 21 | open Cohttp_lwt_unix.Private
 22 | include Websocket.Make (IO)
 23 | 
 24 | let src = Logs.Src.create "websocket_lwt_unix"
 25 | 
 26 | module Lo = (val Logs.src_log src : Logs.LOG)
 27 | 
 28 | exception HTTP_Error of string
 29 | 
 30 | let http_error msg = Lwt.fail (HTTP_Error msg)
 31 | let protocol_error msg = Lwt.fail (Protocol_error msg)
 32 | 
 33 | let set_tcp_nodelay flow =
 34 |   let open Conduit_lwt_unix in
 35 |   match flow with
 36 |   | TCP { fd; _ } -> Lwt_unix.setsockopt fd Lwt_unix.TCP_NODELAY true
 37 |   | _ -> ()
 38 | 
 39 | let fail_unless eq f = if not eq then f () else Lwt.return_unit
 40 | let fail_if eq f = if eq then f () else Lwt.return_unit
 41 | 
 42 | let drain_handshake req ic oc nonce =
 43 |   Request.write ~flush:true (fun _writer -> Lwt.return ()) req oc >>= fun () ->
 44 |   ( Response.read ic >>= function
 45 |     | `Ok r -> Lwt.return r
 46 |     | `Eof -> Lwt.fail End_of_file
 47 |     | `Invalid s -> Lwt.fail @@ Failure s )
 48 |   >>= fun response ->
 49 |   let open Cohttp in
 50 |   let status = Response.status response in
 51 |   let headers = Response.headers response in
 52 |   fail_if
 53 |     Code.(is_error @@ code_of_status status)
 54 |     (fun () -> http_error Code.(string_of_status status))
 55 |   >>= fun () ->
 56 |   fail_unless
 57 |     (Response.version response = `HTTP_1_1)
 58 |     (fun () -> protocol_error "wrong http version")
 59 |   >>= fun () ->
 60 |   fail_unless (status = `Switching_protocols) (fun () ->
 61 |       protocol_error "wrong status")
 62 |   >>= fun () ->
 63 |   (match Header.get headers "upgrade" with
 64 |   | Some a when String.Ascii.lowercase a = "websocket" -> Lwt.return_unit
 65 |   | _ -> protocol_error "wrong upgrade")
 66 |   >>= fun () ->
 67 |   fail_unless (upgrade_present headers) (fun () ->
 68 |       protocol_error "upgrade header not present")
 69 |   >>= fun () ->
 70 |   match Header.get headers "sec-websocket-accept" with
 71 |   | Some accept when accept = b64_encoded_sha1sum (nonce ^ websocket_uuid) ->
 72 |       Lwt.return_unit
 73 |   | _ -> protocol_error "wrong accept"
 74 | 
 75 | let connect ctx client url nonce extra_headers =
 76 |   let open Cohttp in
 77 |   let headers =
 78 |     Header.add_list extra_headers
 79 |       [
 80 |         ("Upgrade", "websocket");
 81 |         ("Connection", "Upgrade");
 82 |         ("Sec-WebSocket-Key", nonce);
 83 |         ("Sec-WebSocket-Version", "13");
 84 |       ]
 85 |   in
 86 |   let req = Request.make ~headers url in
 87 |   Conduit_lwt_unix.connect ~ctx client >>= fun (flow, ic, oc) ->
 88 |   let ic = Input_channel.create ic in
 89 |   set_tcp_nodelay flow;
 90 |   Lwt.catch
 91 |     (fun () -> drain_handshake req ic oc nonce)
 92 |     (fun exn -> Input_channel.close ic >>= fun () -> Lwt.fail exn)
 93 |   >>= fun () ->
 94 |   Lo.info (fun m -> m "Connected to %a" Uri.pp_hum url);
 95 |   Lwt.return (ic, oc)
 96 | 
 97 | type conn = {
 98 |   read_frame : unit -> Frame.t Lwt.t;
 99 |   write_frame : Websocket.Frame.t -> unit Lwt.t;
100 |   oc : Lwt_io.output_channel;
101 | }
102 | 
103 | let read { read_frame; _ } = read_frame ()
104 | let write { write_frame; _ } frame = write_frame frame
105 | let close_transport { oc; _ } = Lwt_io.close oc
106 | 
107 | let connect ?(extra_headers = Cohttp.Header.init ())
108 |     ?(random_string = Websocket.Rng.init ())
109 |     ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx) ?buf client url =
110 |   let nonce = Base64.encode_exn (random_string 16) in
111 |   connect ctx client url nonce extra_headers >|= fun (ic, oc) ->
112 |   let read_frame = make_read_frame ?buf ~mode:(Client random_string) ic oc in
113 |   let read_frame () =
114 |     Lwt.catch read_frame (fun exn ->
115 |         Lwt.async (fun () -> Input_channel.close ic);
116 |         Lwt.fail exn)
117 |   in
118 |   let buf = Buffer.create 128 in
119 |   let write_frame frame =
120 |     Buffer.clear buf;
121 |     Lwt.wrap2 (write_frame_to_buf ~mode:(Client random_string)) buf frame
122 |     >>= fun () ->
123 |     Lwt.catch
124 |       (fun () ->
125 |         Lwt_io.write oc (Buffer.contents buf) >>= fun () -> Lwt_io.flush oc)
126 |       (fun exn ->
127 |         Lwt.async (fun () -> Lwt_io.close oc);
128 |         Lwt.fail exn)
129 |   in
130 |   { read_frame; write_frame; oc }
131 | 
132 | let write_failed_response oc =
133 |   let body = "403 Forbidden" in
134 |   let body_len = String.length body |> Int64.of_int in
135 |   let response =
136 |     Cohttp.Response.make ~status:`Forbidden
137 |       ~encoding:(Cohttp.Transfer.Fixed body_len) ()
138 |   in
139 |   let open Response in
140 |   write ~flush:true (fun writer -> write_body writer body) response oc
141 | 
142 | let server_fun ?read_buf ?write_buf check_request ic oc react =
143 |   let read = function
144 |     | `Ok r -> Lwt.return r
145 |     | `Eof ->
146 |         (* Remote endpoint closed connection. No further action necessary here. *)
147 |         Lo.info (fun m -> m "Remote endpoint closed connection");
148 |         Lwt.fail End_of_file
149 |     | `Invalid reason ->
150 |         Lo.info (fun m -> m "Invalid input from remote endpoint: %s" reason);
151 |         Lwt.fail @@ HTTP_Error reason
152 |   in
153 |   Request.read ic >>= read >>= fun request ->
154 |   let meth = Cohttp.Request.meth request in
155 |   let version = Cohttp.Request.version request in
156 |   let headers = Cohttp.Request.headers request in
157 |   let key = Cohttp.Header.get headers "sec-websocket-key" in
158 |   (match
159 |      ( version,
160 |        meth,
161 |        Cohttp.Header.get headers "upgrade",
162 |        key,
163 |        upgrade_present headers,
164 |        check_request request )
165 |    with
166 |   | `HTTP_1_1, `GET, Some up, Some key, true, true
167 |     when String.Ascii.lowercase up = "websocket" ->
168 |       Lwt.return key
169 |   | _ ->
170 |       write_failed_response oc >>= fun () ->
171 |       Lwt.fail (Protocol_error "Bad headers"))
172 |   >>= fun key ->
173 |   let hash = key ^ websocket_uuid |> b64_encoded_sha1sum in
174 |   let response_headers =
175 |     Cohttp.Header.of_list
176 |       [
177 |         ("Upgrade", "websocket");
178 |         ("Connection", "Upgrade");
179 |         ("Sec-WebSocket-Accept", hash);
180 |       ]
181 |   in
182 |   let response =
183 |     Cohttp.Response.make ~status:`Switching_protocols
184 |       ~encoding:Cohttp.Transfer.Unknown ~headers:response_headers ()
185 |   in
186 |   Response.write ~flush:true (fun _writer -> Lwt.return_unit) response oc
187 |   >>= fun () ->
188 |   let client = Connected_client.create ?read_buf ?write_buf request ic oc in
189 |   react client
190 | 
191 | let establish_server ?read_buf ?write_buf ?timeout ?stop
192 |     ?(on_exn = fun exn -> !Lwt.async_exception_hook exn)
193 |     ?(check_request = check_origin_with_host)
194 |     ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx) ~mode react =
195 |   let module C = Cohttp in
196 |   Conduit_lwt_unix.serve ~on_exn ?timeout ?stop ~ctx ~mode (fun flow ic oc ->
197 |       let ic = Input_channel.create ic in
198 |       set_tcp_nodelay flow;
199 |       Lwt.catch
200 |         (fun () -> server_fun ?read_buf ?write_buf check_request ic oc react)
201 |         (function
202 |           | End_of_file -> Lwt.return_unit
203 |           | HTTP_Error _ -> Lwt.return_unit
204 |           | exn -> Lwt.fail exn))
205 | 
206 | let mk_frame_stream recv =
207 |   let f () =
208 |     recv () >>= fun fr ->
209 |     match fr.Frame.opcode with
210 |     | Frame.Opcode.Close -> Lwt.return_none
211 |     | _ -> Lwt.return (Some fr)
212 |   in
213 |   Lwt_stream.from f
214 | 
215 | let establish_standard_server ?read_buf ?write_buf ?timeout ?stop ?on_exn
216 |     ?check_request ?(ctx = Lazy.force Conduit_lwt_unix.default_ctx) ~mode react
217 |     =
218 |   let f client = react (Connected_client.make_standard client) in
219 |   establish_server ?read_buf ?write_buf ?timeout ?stop ?on_exn ?check_request
220 |     ~ctx ~mode f
221 | 


--------------------------------------------------------------------------------
/lwt/websocket_lwt_unix.mli:
--------------------------------------------------------------------------------
 1 | (*
 2 |  * Copyright (c) 2012-2018 Vincent Bernardoff <vb@luminar.eu.org>
 3 |  *
 4 |  * Permission to use, copy, modify, and distribute this software for any
 5 |  * purpose with or without fee is hereby granted, provided that the above
 6 |  * copyright notice and this permission notice appear in all copies.
 7 |  *
 8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 |  *
16 |  *)
17 | 
18 | (** This module implements a websocket client and server library in the spirit
19 |     of the otherwise similar TCP functions of the [Lwt_io] module. The websocket
20 |     protocol add message framing in addition of simple TCP communication, and
21 |     this library implement framing and unframing of messages. *)
22 | 
23 | include
24 |   Websocket.S
25 |     with type 'a IO.t := 'a Cohttp_lwt_unix.Private.IO.t
26 |      and type IO.ic := Cohttp_lwt_unix.Private.IO.ic
27 |      and type IO.oc := Cohttp_lwt_unix.Private.IO.oc
28 | 
29 | type conn
30 | 
31 | val read : conn -> Websocket.Frame.t Lwt.t
32 | val write : conn -> Websocket.Frame.t -> unit Lwt.t
33 | 
34 | val close_transport : conn -> unit Lwt.t
35 | (** [close_transport conn] closes the underlying transport. You have to manage
36 |     the connection state (ie. send close frames, etc.) yourself. *)
37 | 
38 | val connect :
39 |   ?extra_headers:Cohttp.Header.t ->
40 |   ?random_string:(int -> string) ->
41 |   ?ctx:Conduit_lwt_unix.ctx ->
42 |   ?buf:Buffer.t ->
43 |   Conduit_lwt_unix.client ->
44 |   Uri.t ->
45 |   conn Lwt.t
46 | 
47 | val establish_server :
48 |   ?read_buf:Buffer.t ->
49 |   ?write_buf:Buffer.t ->
50 |   ?timeout:int ->
51 |   ?stop:unit Lwt.t ->
52 |   ?on_exn:(exn -> unit) ->
53 |   ?check_request:(Cohttp.Request.t -> bool) ->
54 |   ?ctx:Conduit_lwt_unix.ctx ->
55 |   mode:Conduit_lwt_unix.server ->
56 |   (Connected_client.t -> unit Lwt.t) ->
57 |   unit Lwt.t
58 | (** [exception_handler] defaults to [Lwt.async_exception_hook] [check_request]
59 |     is called before the http upgrade. If it returns false, the websocket
60 |     connection is aborted with a "403 Forbidden" response. It defaults to
61 |     {!check_origin_with_host} *)
62 | 
63 | (** {2 Convenience functions} *)
64 | 
65 | val mk_frame_stream :
66 |   (unit -> Websocket.Frame.t Lwt.t) -> Websocket.Frame.t Lwt_stream.t
67 | (** [mk_frame_stream f] is a stream build from [f], which role is to receive the
68 |     frames that will form the stream. When a Close frame is received, the stream
69 |     will be closed. *)
70 | 
71 | val establish_standard_server :
72 |   ?read_buf:Buffer.t ->
73 |   ?write_buf:Buffer.t ->
74 |   ?timeout:int ->
75 |   ?stop:unit Lwt.t ->
76 |   ?on_exn:(exn -> unit) ->
77 |   ?check_request:(Cohttp.Request.t -> bool) ->
78 |   ?ctx:Conduit_lwt_unix.ctx ->
79 |   mode:Conduit_lwt_unix.server ->
80 |   (Connected_client.t -> unit Lwt.t) ->
81 |   unit Lwt.t
82 | (** [establish_standard_server] is like {!establish_server} but with automatic
83 |     handling of some frames:
84 | 
85 |     - A Pong frame is sent in response to a Ping frame,
86 |     - a Close frame is sent in response to a Close frame.
87 | 
88 |     All frames are then passed to the frame handling function. *)
89 | 


--------------------------------------------------------------------------------
/lwt/wscat.ml:
--------------------------------------------------------------------------------
  1 | open Lwt.Infix
  2 | open Websocket_lwt_unix
  3 | 
  4 | let src = Logs.Src.create "wscat"
  5 | 
  6 | module Lo = (val Logs.src_log src : Logs.LOG)
  7 | 
  8 | let client uri =
  9 |   let open Websocket in
 10 |   Resolver_lwt.resolve_uri ~uri Resolver_lwt_unix.system >>= fun endp ->
 11 |   let ctx = Lazy.force Conduit_lwt_unix.default_ctx in
 12 |   Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client ->
 13 |   connect ~ctx client uri >>= fun conn ->
 14 |   let close_sent = ref false in
 15 |   let rec react () =
 16 |     Websocket_lwt_unix.read conn >>= function
 17 |     | { Frame.opcode = Ping; _ } ->
 18 |         write conn (Frame.create ~opcode:Pong ()) >>= react
 19 |     | { opcode = Close; content; _ } ->
 20 |         (* Immediately echo and pass this last message to the user *)
 21 |         (if !close_sent then Lwt.return_unit
 22 |          else if String.length content >= 2 then
 23 |            write conn
 24 |              (Frame.create ~opcode:Close ~content:(String.sub content 0 2) ())
 25 |          else write conn (Frame.close 1000))
 26 |         >>= fun () -> Websocket_lwt_unix.close_transport conn
 27 |     | { opcode = Pong; _ } -> react ()
 28 |     | { opcode = Text; content; _ } | { opcode = Binary; content; _ } ->
 29 |         Lwt_io.printf "> %s\n> %!" content >>= react
 30 |     | _ -> Websocket_lwt_unix.close_transport conn
 31 |   in
 32 |   let rec pushf () =
 33 |     Lwt_io.(read_line_opt stdin) >>= function
 34 |     | None ->
 35 |         Lo.debug (fun m -> m "Got EOF. Sending a close frame");
 36 |         write conn (Frame.create ~opcode:Close ()) >>= fun () ->
 37 |         close_sent := true;
 38 |         pushf ()
 39 |     | Some content -> write conn (Frame.create ~content ()) >>= pushf
 40 |   in
 41 |   pushf () <?> react ()
 42 | 
 43 | let rec react client client_id =
 44 |   let open Websocket in
 45 |   Connected_client.recv client >>= fun fr ->
 46 |   Lo.debug (fun m -> m "Client %d: %S" client_id Frame.(show fr));
 47 |   match fr.opcode with
 48 |   | Frame.Opcode.Ping ->
 49 |       Connected_client.send client
 50 |         Frame.(create ~opcode:Opcode.Pong ~content:fr.content ())
 51 |       >>= fun () -> react client client_id
 52 |   | Close ->
 53 |       (* Immediately echo and pass this last message to the user *)
 54 |       if String.length fr.content >= 2 then
 55 |         let content = String.sub fr.content 0 2 in
 56 |         Connected_client.send client
 57 |           Frame.(create ~opcode:Opcode.Close ~content ())
 58 |       else Connected_client.send client @@ Frame.close 1000
 59 |   | Pong -> react client client_id
 60 |   | Text | Binary ->
 61 |       Connected_client.send client fr >>= fun () -> react client client_id
 62 |   | _ -> Connected_client.send client Frame.(close 1002)
 63 | 
 64 | let server uri =
 65 |   let id = ref (-1) in
 66 |   let echo_fun client =
 67 |     incr id;
 68 |     let id = !id in
 69 |     Lo.info (fun m -> m "Connection from client id %d" id);
 70 |     Lwt.catch
 71 |       (fun () -> react client id)
 72 |       (fun exn ->
 73 |         Lo.err (fun m -> m "Client %d error" id);
 74 |         Lwt.fail exn)
 75 |   in
 76 |   Resolver_lwt.resolve_uri ~uri Resolver_lwt_unix.system >>= fun endp ->
 77 |   let open Conduit_lwt_unix in
 78 |   let endp_str = endp |> Conduit.sexp_of_endp |> Sexplib.Sexp.to_string_hum in
 79 |   Lo.info (fun m -> m "endp = %s" endp_str);
 80 |   let ctx = Lazy.force default_ctx in
 81 |   endp_to_server ~ctx endp >>= fun server ->
 82 |   let server_str = server |> sexp_of_server |> Sexplib.Sexp.to_string_hum in
 83 |   Lo.info (fun m -> m "server = %s" server_str);
 84 |   establish_server ~ctx ~mode:server echo_fun
 85 | 
 86 | let main is_server uri =
 87 |   if !is_server then (
 88 |     ignore @@ server uri;
 89 |     fst @@ Lwt.wait ())
 90 |   else client uri
 91 | 
 92 | let apply_loglevel = function
 93 |   | 2 -> Logs.set_level ~all:true (Some Info)
 94 |   | 3 -> Logs.set_level ~all:true (Some Debug)
 95 |   | _ -> ()
 96 | 
 97 | let () =
 98 |   let uri = ref "" in
 99 |   let server = ref false in
100 |   let speclist =
101 |     Arg.align
102 |       [
103 |         ("-s", Arg.Set server, " Run as server");
104 |         ("-loglevel", Arg.Int apply_loglevel, "1-3 Set loglevel");
105 |       ]
106 |   in
107 |   let anon_fun s = uri := s in
108 |   let usage_msg = "Usage: " ^ Sys.argv.(0) ^ " <options> uri\nOptions are:" in
109 |   Arg.parse speclist anon_fun usage_msg;
110 |   Lwt_main.run (main server (Uri.of_string !uri))
111 | 


--------------------------------------------------------------------------------
/test/dune:
--------------------------------------------------------------------------------
 1 | (executable
 2 |  (name reynir)
 3 |  (modules reynir)
 4 |  (libraries conduit-lwt-unix websocket-lwt-unix))
 5 | 
 6 | (executable
 7 |  (name upgrade_connection)
 8 |  (modules upgrade_connection)
 9 |  (libraries logs.fmt logs.lwt websocket_cohttp_lwt sexplib))
10 | 


--------------------------------------------------------------------------------
/test/reynir.ml:
--------------------------------------------------------------------------------
 1 | open Lwt.Infix
 2 | open Websocket
 3 | open Websocket_lwt_unix
 4 | 
 5 | let src = Logs.Src.create "reynir"
 6 | 
 7 | module Lo = (val Logs.src_log src : Logs.LOG)
 8 | 
 9 | let handler id client =
10 |   incr id;
11 |   let id = !id in
12 |   let send = Connected_client.send client in
13 |   Lo.info (fun m -> m "New connection (id = %d)" id);
14 |   Lwt.async (fun () ->
15 |       Lwt_unix.sleep 1.0 >>= fun () ->
16 |       send @@ Frame.create ~content:"Delayed message" ());
17 |   let rec recv_forever () =
18 |     let open Frame in
19 |     let react fr =
20 |       Lo.debug (fun m -> m "<- %s" (Frame.show fr));
21 |       match fr.opcode with
22 |       | Opcode.Ping ->
23 |           send @@ Frame.create ~opcode:Opcode.Pong ~content:fr.content ()
24 |       | Opcode.Close ->
25 |           Lo.info (fun m -> m "Client %d sent a close frame" id);
26 |           (* Immediately echo and pass this last message to the user *)
27 |           (if String.length fr.content >= 2 then
28 |              send
29 |              @@ Frame.create ~opcode:Opcode.Close
30 |                   ~content:(String.sub fr.content 0 2)
31 |                   ()
32 |            else send @@ Frame.close 1000)
33 |           >>= fun () -> Lwt.fail Exit
34 |       | Opcode.Pong -> Lwt.return_unit
35 |       | Opcode.Text | Opcode.Binary -> send @@ Frame.create ~content:"OK" ()
36 |       | _ -> send @@ Frame.close 1002 >>= fun () -> Lwt.fail Exit
37 |     in
38 |     Connected_client.recv client >>= react >>= recv_forever
39 |   in
40 |   Lwt.catch recv_forever (fun exn ->
41 |       Lo.info (fun m -> m "Connection to client %d lost" id);
42 |       Lwt.fail exn)
43 | 
44 | let main uri =
45 |   Resolver_lwt.resolve_uri ~uri Resolver_lwt_unix.system >>= fun endp ->
46 |   let open Conduit_lwt_unix in
47 |   let ctx = Lazy.force default_ctx in
48 |   endp_to_server ~ctx endp >>= fun server ->
49 |   establish_server ~ctx ~mode:server (handler @@ ref (-1))
50 | 
51 | let () =
52 |   let uri = ref "http://localhost:9001" in
53 |   let speclist =
54 |     Arg.align
55 |       [
56 |         ( "-v",
57 |           Arg.String (fun _ -> Logs.set_level ~all:true (Some Info)),
58 |           " Info level" );
59 |         ( "-vv",
60 |           Arg.String (fun _ -> Logs.set_level ~all:true (Some Info)),
61 |           " Debug level" );
62 |       ]
63 |   in
64 |   let anon_fun s = uri := s in
65 |   let usage_msg = "Usage: " ^ Sys.argv.(0) ^ " <options> uri\nOptions are:" in
66 |   Arg.parse speclist anon_fun usage_msg;
67 |   ignore @@ main @@ Uri.of_string !uri;
68 |   Lwt_main.run (fst (Lwt.wait ()))
69 | 


--------------------------------------------------------------------------------
/test/upgrade_connection.ml:
--------------------------------------------------------------------------------
  1 | open Lwt.Infix
  2 | open Websocket
  3 | 
  4 | let src = Logs.Src.create "websocket.upgrade_connection"
  5 | 
  6 | module Lo = (val Logs.src_log src : Logs.LOG)
  7 | 
  8 | let lwt_reporter () =
  9 |   let buf_fmt ~like =
 10 |     let b = Buffer.create 512 in
 11 |     ( Fmt.with_buffer ~like b,
 12 |       fun () ->
 13 |         let m = Buffer.contents b in
 14 |         Buffer.reset b;
 15 |         m )
 16 |   in
 17 |   let app, app_flush = buf_fmt ~like:Fmt.stdout in
 18 |   let dst, dst_flush = buf_fmt ~like:Fmt.stderr in
 19 |   let reporter = Logs_fmt.reporter ~app ~dst () in
 20 |   let report src level ~over k msgf =
 21 |     let k () =
 22 |       let write () =
 23 |         match level with
 24 |         | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ())
 25 |         | _ -> Lwt_io.write Lwt_io.stderr (dst_flush ())
 26 |       in
 27 |       let unblock () =
 28 |         over ();
 29 |         Lwt.return_unit
 30 |       in
 31 |       Lwt.finalize write unblock |> Lwt.ignore_result;
 32 |       k ()
 33 |     in
 34 |     reporter.Logs.report src level ~over:(fun () -> ()) k msgf
 35 |   in
 36 |   { Logs.report }
 37 | 
 38 | let handler (_, _conn) req body =
 39 |   let open Frame in
 40 |   Lo.app (fun m -> m "[CONN]");
 41 |   let uri = Cohttp.Request.uri req in
 42 |   match Uri.path uri with
 43 |   | "/" ->
 44 |       Logs_lwt.app ~src (fun m -> m "[PATH] /") >>= fun () ->
 45 |       Cohttp_lwt_unix.Server.respond_string ~status:`OK
 46 |         ~body:
 47 |           {|
 48 |         <html>
 49 |         <head>
 50 |             <meta charset="utf-8">
 51 |             <script src="//code.jquery.com/jquery-1.11.3.min.js"></script>
 52 |             <script>
 53 |                 $(window).on('load', function(){
 54 |                     ws = new WebSocket('ws://localhost:7777/ws');
 55 |                     ws.onmessage = function(x) {
 56 |                         console.log(x.data);
 57 |                         var m = "<- Pong " + parseInt((x.data.substring(8)) - 1);
 58 |                         $('#msg').html("<p>" + x.data + "</p><p>" + m + "</p>");
 59 |                         ws.send(m);
 60 |                     };
 61 |                 });
 62 |         </script>
 63 |         </head>
 64 |         <body>
 65 |             <div id='msg'></div>
 66 |         </body>
 67 |         </html>
 68 |         |}
 69 |         ()
 70 |       >|= fun resp -> `Response resp
 71 |   | "/ws" ->
 72 |       Logs_lwt.app ~src (fun m -> m "[PATH] /ws") >>= fun () ->
 73 |       Cohttp_lwt.Body.drain_body body >>= fun () ->
 74 |       Websocket_cohttp_lwt.upgrade_connection req (fun { opcode; content; _ } ->
 75 |           match opcode with
 76 |           | Opcode.Close -> Logs.app ~src (fun m -> m "[RECV] CLOSE")
 77 |           | _ -> Logs.app ~src (fun m -> m "[RECV] %s" content))
 78 |       >>= fun (resp, frames_out_fn) ->
 79 |       (* send a message to the client every second *)
 80 |       let num_ref = ref 10 in
 81 |       let rec go () =
 82 |         if !num_ref = 0 then Logs_lwt.app ~src (fun m -> m "[INFO] Test done")
 83 |         else
 84 |           let msg = Printf.sprintf "-> Ping %d" !num_ref in
 85 |           Logs_lwt.app ~src (fun m -> m "[SEND] %s" msg) >>= fun () ->
 86 |           Lwt.wrap1 frames_out_fn @@ Some (Frame.create ~content:msg ())
 87 |           >>= fun () ->
 88 |           decr num_ref;
 89 |           Lwt_unix.sleep 1. >>= go
 90 |       in
 91 |       Lwt.async go;
 92 |       Lwt.return resp
 93 |   | _ ->
 94 |       Logs_lwt.app ~src (fun m -> m "[PATH] Catch-all") >>= fun () ->
 95 |       Cohttp_lwt_unix.Server.respond_string ~status:`Not_found
 96 |         ~body:(Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))
 97 |         ()
 98 |       >|= fun resp -> `Response resp
 99 | 
100 | let start_server ?tls port =
101 |   let conn_closed (_, _c) = Lo.app (fun m -> m "[SERV] connection closed") in
102 |   Logs_lwt.app ~src (fun m -> m "[SERV] Listening for HTTP on port %d" port)
103 |   >>= fun () ->
104 |   let mode =
105 |     match tls with
106 |     | None ->
107 |         Logs.app ~src (fun m -> m "TCP mode selected");
108 |         `TCP (`Port port)
109 |     | Some (cert, key) ->
110 |         Logs.app ~src (fun m -> m "TLS mode selected");
111 |         `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
112 |   in
113 |   Cohttp_lwt_unix.Server.create ~mode
114 |     (Cohttp_lwt_unix.Server.make_response_action ~callback:handler ~conn_closed
115 |        ())
116 | 
117 | let () =
118 |   Logs.(set_reporter (lwt_reporter ()));
119 |   let port = ref 7777 in
120 |   let cert = ref "" in
121 |   let key = ref "" in
122 |   let speclist =
123 |     Arg.align
124 |       [
125 |         ("-cert", Arg.Set_string cert, " cert file");
126 |         ("-key", Arg.Set_string key, " key file");
127 |         ( "-v",
128 |           Arg.Unit (fun () -> Logs.set_level (Some Info)),
129 |           " Set loglevel to info" );
130 |         ( "-vv",
131 |           Arg.Unit (fun () -> Logs.set_level (Some Debug)),
132 |           " Set loglevel to debug" );
133 |       ]
134 |   in
135 |   let anon_fun s =
136 |     match int_of_string_opt s with
137 |     | None -> invalid_arg "argument must be a port number"
138 |     | Some p -> port := p
139 |   in
140 |   let usage_msg = "Usage: " ^ Sys.argv.(0) ^ " <options> port\nOptions are:" in
141 |   Arg.parse speclist anon_fun usage_msg;
142 |   let tls =
143 |     match (!cert, !key) with
144 |     | "", _ | _, "" -> None
145 |     | cert, key -> Some (cert, key)
146 |   in
147 |   Lwt_main.run (start_server ?tls !port)
148 | 


--------------------------------------------------------------------------------
/websocket-lwt-unix.opam:
--------------------------------------------------------------------------------
 1 | # This file is generated by dune, edit dune-project instead
 2 | opam-version: "2.0"
 3 | synopsis: "Websocket library (Lwt)"
 4 | description: """
 5 | The WebSocket Protocol enables two-way communication between a client
 6 | running untrusted code in a controlled environment to a remote host
 7 | that has opted-in to communications from that code.
 8 | 
 9 | The security model used for this is the origin-based security model
10 | commonly used by web browsers. The protocol consists of an opening
11 | handshake followed by basic message framing, layered over TCP.
12 | 
13 | The goal of this technology is to provide a mechanism for
14 | browser-based applications that need two-way communication with
15 | servers that does not rely on opening multiple HTTP connections (e.g.,
16 | using XMLHttpRequest or <iframe>s and long polling).
17 | """
18 | maintainer: ["Vincent Bernardoff <vb@luminar.eu.org>"]
19 | authors: ["Vincent Bernardoff <vb@luminar.eu.org>"]
20 | license: "ISC"
21 | tags: ["org:mirage" "org:xapi-project"]
22 | homepage: "https://github.com/vbmithr/ocaml-websocket"
23 | doc: "https://vbmithr.github.io/ocaml-websocket/doc"
24 | bug-reports: "https://github.com/vbmithr/ocaml-websocket/issues"
25 | depends: [
26 |   "dune" {>= "2.9"}
27 |   "ocaml" {>= "4.06.0"}
28 |   "websocket" {= version}
29 |   "logs" {>= "0.8.0"}
30 |   "cohttp-lwt-unix" {>= "5.0.0"}
31 |   "odoc" {with-doc}
32 | ]
33 | build: [
34 |   ["dune" "subst"] {dev}
35 |   [
36 |     "dune"
37 |     "build"
38 |     "-p"
39 |     name
40 |     "-j"
41 |     jobs
42 |     "--promote-install-files=false"
43 |     "@install"
44 |     "@runtest" {with-test}
45 |     "@doc" {with-doc}
46 |   ]
47 |   ["dune" "install" "-p" name "--create-install-files" name]
48 | ]
49 | dev-repo: "git+https://github.com/vbmithr/ocaml-websocket.git"
50 | 


--------------------------------------------------------------------------------
/websocket.opam:
--------------------------------------------------------------------------------
 1 | # This file is generated by dune, edit dune-project instead
 2 | opam-version: "2.0"
 3 | synopsis: "Websocket library"
 4 | description: """
 5 | The WebSocket Protocol enables two-way communication between a client
 6 | running untrusted code in a controlled environment to a remote host
 7 | that has opted-in to communications from that code.
 8 | 
 9 | The security model used for this is the origin-based security model
10 | commonly used by web browsers. The protocol consists of an opening
11 | handshake followed by basic message framing, layered over TCP.
12 | 
13 | The goal of this technology is to provide a mechanism for
14 | browser-based applications that need two-way communication with
15 | servers that does not rely on opening multiple HTTP connections (e.g.,
16 | using XMLHttpRequest or <iframe>s and long polling).
17 | """
18 | maintainer: ["Vincent Bernardoff <vb@luminar.eu.org>"]
19 | authors: ["Vincent Bernardoff <vb@luminar.eu.org>"]
20 | license: "ISC"
21 | tags: ["org:mirage" "org:xapi-project"]
22 | homepage: "https://github.com/vbmithr/ocaml-websocket"
23 | doc: "https://vbmithr.github.io/ocaml-websocket/doc"
24 | bug-reports: "https://github.com/vbmithr/ocaml-websocket/issues"
25 | depends: [
26 |   "dune" {>= "2.9"}
27 |   "ocaml" {>= "4.06.0"}
28 |   "base64" {>= "3.3.0"}
29 |   "conduit" {>= "5.1.0"}
30 |   "cohttp" {>= "5.0.0"}
31 |   "ocplib-endian" {>= "1.0"}
32 |   "astring" {>= "0.8.3"}
33 |   "mirage-crypto-rng" {>= "1.0.0"}
34 |   "odoc" {with-doc}
35 | ]
36 | build: [
37 |   ["dune" "subst"] {dev}
38 |   [
39 |     "dune"
40 |     "build"
41 |     "-p"
42 |     name
43 |     "-j"
44 |     jobs
45 |     "--promote-install-files=false"
46 |     "@install"
47 |     "@runtest" {with-test}
48 |     "@doc" {with-doc}
49 |   ]
50 |   ["dune" "install" "-p" name "--create-install-files" name]
51 | ]
52 | dev-repo: "git+https://github.com/vbmithr/ocaml-websocket.git"
53 | 


--------------------------------------------------------------------------------